Excel to Word macro

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:
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
 

Excel Facts

Can a formula spear through sheets?
Use =SUM(January:December!E7) to sum E7 on all of the sheets from January through December

NdNoviceHlp

Well-known Member
Joined
Nov 9, 2002
Messages
2,803
Good morning texasalynn. The difficulty I had in reading this thread previously was your use of "reading all files in a given directory". Does this mean all Word docs in a folder or something else. Also, in your above code I'm puzzled by "ActiveSheet.Range("A" & r).Formula = tString". Are the Word paragraphs formulas? Also, where to you want to put the paragraphs for more docs... as is they will overwrite the previous paragraphs in "A". Perhaps a bit more explanation will be helpful. Dave
 

texasalynn

Well-known Member
Joined
May 19, 2002
Messages
8,458
Thanks Dave - guess I did leave out some information. My code has some additional code that takes each file reads the data in from Word and puts in Excel, then it transfers the data to Access. So yes each file would overwrite the data in column "A". That way it will read thru each file in a given directory. Does that explain it better?
 

NdNoviceHlp

Well-known Member
Joined
Nov 9, 2002
Messages
2,803

ADVERTISEMENT

I made some changes. No need for a reference to Word library. This is a solution assuming that you have Word docs in a folder. You could probably also do something like.. For each Doc in Folder etc. instead of naming them in an array. Hope this gets you started. Dave
ps. I changed "formula" to value. Also this routine continues to load paragraphs from each doc into the next "A" row. You will need to alter the looping to load from doc, do access stuff, then reset "A" to 3, load doc, do access stuff etc. etc.
Code:
Sub OpenAndReadWordDoc()
    Dim wrdapp As Object, cnt As Integer
    Dim DocArray() As Variant, Position As String
    Dim tString As String

    'docs in folder list
    DocArray = Array("fix4", "fix8", "fix11")

    Sheets("sheet1").Activate
    With Range("A1")
        .Value = "Word Document Contents:"
        .Font.Bold = True
        .Font.Size = 14
        .Offset(1, 0).Select
    End With
    
    ' startrow for the copied text from the Word document
    r = 3
    
    On Error GoTo fixerror
    Set wrdapp = CreateObject("Word.Application")

    'change directory below to suit
    wrdapp.ChangeFileOpenDirectory "c:\2003\"

    For cnt = LBound(DocArray) To UBound(DocArray)
        Position = DocArray(cnt) & ".doc"

        wrdapp.documents.Open Filename:=Position
        wrdapp.ActiveDocument.Select

        For p = 1 To wrdapp.Selection.Paragraphs.Count

            Set tRange = wrdapp.ActiveDocument.Paragraphs(p).Range
            tRange.SetRange Start:=tRange.Start, _
            End:=wrdapp.ActiveDocument.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).Value = tString
                r = r + 1
            End If
        Next p

        wrdapp.ActiveDocument.Close savechanges:=True

    Next cnt

    wrdapp.Quit
    Set wrdapp = Nothing
    Exit Sub

fixerror:
    On Error GoTo 0
    MsgBox "File error (most likely)"
    wrdapp.Quit
    Set wrdapp = Nothing
End Sub
 

texasalynn

Well-known Member
Joined
May 19, 2002
Messages
8,458
:LOL: :LOL: :LOL: :cool:

I finally got it to work - here is the final code. To help the next one looking for something similiar
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
Dim objFolder As Object
Dim sDir As String
Dim wbDest As Workbook, wbBook As Workbook
Dim wbAllBooks As Workbooks
Dim shtDest As Worksheet
Dim intResponse As Integer, dblSum As Double
Dim rngMyRng As Range, cell As Range

Application.ScreenUpdating = False
Application.DisplayAlerts = False
    
    intResponse = MsgBox("This macro will transfer data in all workbooks of the selected folder to Access table" & vbCrLf & "Close all open workbooks before running this macro", vbExclamation + vbOKCancel, "Summarize Files")
    If intResponse = vbOK Then
        
            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
    
    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
    Set wrdApp = CreateObject("Word.Application")
    Set wrdDoc = wrdApp.Documents.Open(.FoundFiles(lngFilecounter))
   
    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
    ' 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
                Next lngFilecounter
    End With
    
    Worksheets("Start").Activate
    MsgBox "Done"
    ActiveWorkbook.Saved = True
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End If
errorhandler:
End Sub
 

NdNoviceHlp

Well-known Member
Joined
Nov 9, 2002
Messages
2,803
Very nice piece of code and thanks for posting it. :biggrin: There's alot to be learned with that. I thought that you might want to consider changing these 2 lines of code around. It seems like your creating a new instance with every loop? Create 1 and run the files through it seems like it would be better. I haven't trialed the code yet and I don't know. Dave
Code:
For lngFilecounter = 1 To .FoundFiles.Count 
    Set wrdApp = CreateObject("Word.Application")
 

Forum statistics

Threads
1,141,629
Messages
5,707,506
Members
421,511
Latest member
mgroah1

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top