texasalynn
Well-known Member
- Joined
- May 19, 2002
- Messages
- 8,458
I have some code that takes Word document and reads it into Excel. No problem. Now I need to have that code read "ALL" files within a given directory to process. I have found some great code for that, but I can't figure out how to incorporate the two together.
Here is my code:
here is the code that prcoess data from a directory/folder
appreciate any help that someone may have
Here is my code:
Code:
Sub OpenAndReadWordDoc()
Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Dim tString As String, tRange As Word.Range
Dim p As Long, r As Long
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Worksheets("Input Data").Activate
With Range("A1")
.Formula = "Word Document Contents:"
.Font.Bold = True
.Font.Size = 14
.Offset(1, 0).Select
End With
r = 3 ' startrow for the copied text from the Word document
Set wrdApp = CreateObject("Word.Application")
FilePath = Application.GetOpenFilename("Microsoft Word Document(*.doc), *.doc")
Set wrdDoc = wrdApp.Documents.Open(FilePath)
' example word operations
With wrdDoc
For p = 1 To .Paragraphs.Count
Set tRange = .Range(Start:=.Paragraphs(p).Range.Start, _
End:=.Paragraphs(p).Range.End)
tString = tRange.Text
tString = Left(tString, Len(tString) - 1)
' check if the text has content
If tString <> "" Then
' fill into active worksheet
ActiveSheet.Range("A" & r).Formula = tString
r = r + 1
End If
Next p
.Close ' close the document
End With
Set wrdDoc = Nothing
Set wrdApp = Nothing
Call TrimChr
Call cTransfer
Call CSUpdates
Worksheets("Input Data").Activate
Range("A:A").Clear
Worksheets("Start").Activate
MsgBox "Done"
ActiveWorkbook.Saved = True
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
here is the code that prcoess data from a directory/folder
Code:
Option Explicit
'//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~//'
Sub CombineFiles()
Dim objFolder As Object
Dim sDir As String
Dim wbDest As Workbook, wbBook As Workbook
Dim wbAllBooks As Workbooks
Dim lngFilecounter As Long
Dim shtDest As Worksheet
Dim intResponse As Integer, dblSum As Double
Dim rngMyRng As Range, cell As Range
intResponse = MsgBox("This macro will summarize data in all workbooks in the user selected folder." & vbCrLf & "Close all open workbooks before running this macro", vbExclamation + vbOKCancel, "Summarize Files")
If intResponse = vbOK Then
Application.DisplayAlerts = False
On Error GoTo errorhandler
'// Selects the Root PC Dir!
Set objFolder = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please Select Folder", 0, 0)
If Not objFolder Is Nothing Then
'// Is it the Root Dir?...if so change
If Len(objFolder.Items.Item.Path) > 3 Then
sDir = objFolder.Items.Item.Path & Application.PathSeparator
Else
sDir = objFolder.Items.Item.Path
End If
End If
Set objFolder = Nothing 'release object from memory
If Len(sDir) = 0 Then Exit Sub
Application.ScreenUpdating = False
Set shtDest = ThisWorkbook.Sheets(1)
With Application.FileSearch
.NewSearch
.LookIn = sDir
.FileType = msoFileTypeWordDocuments
.Execute
If .FoundFiles.Count = 0 Then Exit Sub
'Process each file in folder
For lngFilecounter = 1 To .FoundFiles.Count
Workbooks.Open (.FoundFiles(lngFilecounter))
Next lngFilecounter
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End If
errorhandler:
End Sub
appreciate any help that someone may have