Getting Data from Word Tables into Excel

[johnodocs]

Hi all

I was wondering if anyone could help me out with a problem. I have about 1,500 word documents with tables that represent student evaluation. It is a tick box exercise where we have very good, good, needs work.

I was wondering if it would be possible to make some VBA code that opens each documents looks inside the table to see if an X appears in certain columns, and then report back to the spreadsheet, counting the numbers. I basically want to know all the times an X appears in 'needs work' in order to understand what students need help.

Hope this is enough to get some smart creative out there thinking.

Thanks in advanced

John

 

[pbornemeier]

Re: Newbie Question - Getting Data from Word Tables into Excel

Is there more than one table in each word document? (Possibly)
Are there multiple rows in each table? (Yes)
Does it matter which rows contain the X? (No)
Does the name of the document contain the student name? (Document Name included in Output)

This code is written using the above assumptions:

Option Explicit
Sub TableCheck()
    'https://www.mrexcel.com/forum/excel-questions/1047327-newbie-question-getting-data-word-tables-into-excel.html
    'Examine each Word document in sFilePath for tables that have a top row entry of "Needs Work" (case insensitive)
    '    and counts the number of cells that contain X or x in that column.  Reports filename and X count
    
    Dim sFilePath As String
    '====================== Update with Word documents file path.  Include \ at end ======================
    sFilePath = Environ("userprofile") & "\Documents\Evaluations\"
    
    Dim sWorksheet As String
    '====================== Update with desired name of worksheet for data ======================
    sWorksheet = "Word Doc Table Analysis"
    
    Dim sFileNameExt As String
    Dim lNextWriteLine As Long
    Dim lWordCount As Long
    Dim appWD As Object
    Set appWD = CreateObject("Word.Application")
    Dim lTblCount As Long
    Dim lColCount As Long
    Dim tbl As Object
    Dim col As Object
    Dim celRow As Object
    Dim celCol As Object
    Dim lCol As Long
    Dim lXCount As Long
    
    Dim secAutomation As MsoAutomationSecurity
    secAutomation = appWD.Application.AutomationSecurity                          'Save Word security setting
    appWD.Application.AutomationSecurity = msoAutomationSecurityForceDisable      'Disable macros when opening files
    
    'Delete and recreate worksheet
    On Error Resume Next
    Application.DisplayAlerts = False
    Worksheets(sWorksheet).Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
    Worksheets.Add(after:=Sheets(Sheets.Count)).Name = sWorksheet 'After last
    Worksheets(sWorksheet).Range("A1").Resize(1, 2).Value = Array("FileNameExt", "X Count")
    
    'Ensure filepath has a \ at end
    If Right(sFilePath, 1) <> "\" Then sFilePath = sFilePath & "\"
    appWD.ChangeFileOpenDirectory sFilePath
    
    sFileNameExt = Dir(sFilePath & "*.doc*")
    lNextWriteLine = 1
    
    Do While sFileNameExt <> vbNullString
        Application.StatusBar = sFileNameExt
        lXCount = 0 'Reset document X count
        
        appWD.Documents.Open Filename:=sFilePath & sFileNameExt, ConfirmConversions:=False, _
            ReadOnly:=True, AddToRecentFiles:=False, PasswordDocument:="", PasswordTemplate:="", _
            Revert:=False, WritePasswordDocument:="", WritePasswordTemplate:="", _
            Format:=0, XMLTransform:=""   'Format:=0=wdOpenFormatAuto
            
        If appWD.activedocument.Tables.Count > 0 Then
            For Each tbl In appWD.activedocument.Tables
                For Each celRow In tbl.Rows(1).Cells
                    If InStr(UCase(celRow.Range.Text), "NEEDS WORK") > 0 Then
                        lCol = celRow.ColumnIndex
                        For Each celCol In tbl.Columns(lCol).Cells
                            If InStr(UCase(celCol.Range.Text), "X") > 0 Then
                                lXCount = lXCount + 1
                            End If
                        Next
                    End If
                Next
            Next
        End If
        appWD.activedocument.Close
            
        If lXCount > 0 Then
            lNextWriteLine = lNextWriteLine + 1
            Worksheets(sWorksheet).Cells(lNextWriteLine, 1).Resize(1, 2).Value = Array(sFileNameExt, lXCount)
        End If
        
        sFileNameExt = Dir
        
    Loop
    
    appWD.Application.AutomationSecurity = secAutomation                          'Restore Word security setting
    
    'If program quits before following line use Task Manager to close WINWORD.EXE
    appWD.Quit
    
    Application.StatusBar = False
    
End Sub

 

[johnodocs]

Re: Newbie Question - Getting Data from Word Tables into Excel

Dear pbornemeier

Thanks SO much for replying and bringing this post back from the dead! I had a look at your solution and wasn't able to get it to run (I was probably doing something wrong!).

Anyway, I have come up with some code that does nearly what I want it to too (albeit very crudely) but I have hit a road block here' count the Xs.

I am trying to count the X's in the column I have selected but it doesn't seem to count them and strays into the other cells.

What could this be?

Many thanks!

John

Sub Count_NM()

Dim Path As String

Dim objWord
Dim objDoc
Dim TemplateNeeded As String

Dim myCells As Word.Range
Dim TickCount As Integer
Dim Percentage As Integer
Dim Movers_Flyers As Integer ' 13 possiblities

Sheets("Data").Select
    FinalRow = Range("A9999").End(xlUp).Row
    
    For I = 2 To FinalRow
    
    Path = Sheets("Data").Range("F" & I).Text
    
    TemplateNeeded = Range("D" & I).Value
       
    Set objWord = CreateObject("Word.Application")
    Set objDoc = objWord.Documents.Open(Path)

    objWord.Visible = True
    
    If TemplateNeeded = "EVALUATION REPORT Movers & Flyers" Then
    
    Movers_Flyers = 13
    
    With objWord.ActiveDocument
    
            Set myCells = .Range(Start:=.Tables(1).cell(4, 7).Range.Start, _
            End:=.Tables(1).cell(18, 7).Range.End)
            myCells.Select
            
    ' count the Xs
    
    With myCells.Find
        Do While .Execute(FindText:="X", MatchWholeWord:=True) = True
                                
           y = y + 1
           
           Loop
    
    TickCount = Str$(y)
      
    Percentage = TickCount / Movers_Flyers * 100
      
    Range("L" & I).Value = Percentage
    
    y = 0
    
    objWord.ActiveDocument.Close
        
    End With
    
    '
    
    End With
    
    End If
        
    Next I

End Sub

 

[pbornemeier]

Re: Newbie Question - Getting Data from Word Tables into Excel

VBA find in MSWord is confusing. This site: https://gregmaxey.com/word_tip_pages/words_fickle_vba_find_property.html
talks about it in great detail, but I was not able to follow it well enough to make your Find code work.

I modified your code to use the Instr Function and added a few comments regarding the original code. Please test and let me know if it works.
If you have time, please amplify on how my code was not able to run.

Option Explicit

Sub Count_NM()
    'This site: [URL]https://gregmaxey.com/word_tip_pages/words_fickle_vba_find_property.html[/URL]
    'discusses the perversity of the Word VBA Find function.  I cannot follow it well enough to
    'make it work for your problem.
    
    Dim Path As String
    
    Dim objWord
    Dim objDoc
    Dim TemplateNeeded As String
    
    Dim y As Long
    Dim FinalRow As Long
    Dim I As Long
    
    Dim myCells As Word.Range
    Dim TickCount As Integer
    Dim Percentage As Integer
    Dim Movers_Flyers As Integer ' 13 possiblities
    Dim wdCell As cell
    
    Sheets("Data").Select
    'FinalRow = Range("A9999").End(xlUp).Row        'Will not see rows after 9999
    FinalRow = Cells(Rows.Count, 1).End(xlUp).Row  'Rows.count returns the last row the worksheet
    
    Set objWord = CreateObject("Word.Application")  'Moved from inside loop
    
    For I = 2 To FinalRow
        Path = Sheets("Data").Range("F" & I).Text   'Is the
    
        TemplateNeeded = Range("D" & I).Value
       
        'Set objWord = CreateObject("Word.Application")   'Moved out of For-Next loop.  Don't create a word instance each time
        Set objDoc = objWord.Documents.Open(Path)
        objWord.Visible = True  'Doesn't need to be visible, but if you want to watch, OK
    
        If TemplateNeeded = "EVALUATION REPORT Movers & Flyers" Then
    
            Movers_Flyers = 13
    
            With objWord.ActiveDocument
            
                Set myCells = .Range(Start:=.Tables(1).cell(4, 7).Range.Start, _
                End:=.Tables(1).cell(18, 7).Range.End)
                myCells.Select
            
                y = 0
                For Each wdCell In Selection.Cells
                    If InStr(UCase(wdCell.Range.Text), "X") > 0 Then y = y + 1
                Next
                
'                With myCells.Find
'                    .Forward = True
'
'                    y = 0   'Moved to be prior to use (even though it would be 0 first time)
'
'                    Do While .Execute(FindText:="X", MatchWholeWord:=True) = True   'If this finds any X in mycells then it counts mycells
'                       y = y + 1
'                    Loop
'
'                    'TickCount = Str$(y)  'why make a number into a string?
'                    'Percentage = TickCount / Movers_Flyers * 100  'then force the code to coerce it back to a number?
'                    'Range("L" & I).Value = Percentage
'
                    Range("L" & I).Value = y / Movers_Flyers * 100  'Percentage
                    objWord.ActiveDocument.Close    'close the document, word still exists
    
            End With
    
        End If 'TemplateNeeded = "EVALUATION REPORT Movers & Flyers"
        
    Next I
    
    objWord.Quit    'Close word
    
End Sub

 

[johnodocs]

Re: Newbie Question - Getting Data from Word Tables into Excel

Hi pbornemeier

Thanks once again! I really appreciate the time you are taking with my problem. Unfortunately I am getting a run time error 13 (type mismatch) on this line:

For Each wdCell In Selection.Cells

I am already out of my depth here so any direction is welcome!

thanks

John

 

[pbornemeier]

Re: Newbie Question - Getting Data from Word Tables into Excel

Option Explicit
Sub Count_NM()
    'This site: [URL]https://gregmaxey.com/word_tip_pages..._property.html[/URL]
    'discusses the perversity of the Word VBA Find function.  I cannot follow it well enough to
    'make it work for your problem.
    
    Dim Path As String
    
    Dim objWord
    Dim objDoc
    Dim TemplateNeeded As String
    
    Dim y As Long
    Dim FinalRow As Long
    Dim I As Long
    
    Dim lRow As Long, lCol As Long
    
    Dim myCells As Word.Range
    Dim TickCount As Integer
    Dim Percentage As Integer
    Dim Movers_Flyers As Integer ' 13 possiblities
    Dim wdCell As Cell
    
    Sheets("Data").Select
    'FinalRow = Range("A9999").End(xlUp).Row        'Will not see rows after 9999
    FinalRow = Cells(Rows.Count, 1).End(xlUp).Row  'Rows.count returns the last row the worksheet
    
    Set objWord = CreateObject("Word.Application")  'Moved from inside loop
    
    objWord.Visible = True
    For I = 2 To FinalRow
    
        Path = Sheets("Data").Range("F" & I).Text
        
        Application.StatusBar = Format((I - 1) / (FinalRow - 1), "0.0%") & "  " & Path
        TemplateNeeded = Range("D" & I).Value
       
        'Set objWord = CreateObject("Word.Application")   'Moved out of For-Next loop.  Don't create a word instance each time
        Set objDoc = objWord.Documents.Open(Path)
        'objWord.Visible = True  'Doesn't need to be visible, but if you want to watch, OK
    
        If TemplateNeeded = "EVALUATION REPORT Movers & Flyers" Then
    
            Movers_Flyers = 13
    
            With objWord.ActiveDocument
            
                'Set myCells = .Range(Start:=.Tables(1).Cell(4, 7).Range.Start, End:=.Tables(1).Cell(18, 7).Range.End)
                'myCells.Select
                
                lCol = 7
                y = 0
                For lRow = 4 To 18
                    If InStr(UCase(.Tables(1).Cell(lRow, lCol).Range.Text), "X") > 0 Then y = y + 1
                Next
                
'                With myCells.Find
'                    .Forward = True
'
'                    y = 0   'Moved to be prior to use (even though it would be 0 first time)
'
'                    Do While .Execute(FindText:="X", MatchWholeWord:=True) = True   'If this finds any X in mycells then it counts mycells
'                       y = y + 1
'                    Loop
'
'                    'TickCount = Str$(y)  'why make a number into a string?
'                    'Percentage = TickCount / Movers_Flyers * 100  'then force the code to coerce it back to a number?
'                    'Range("L" & I).Value = Percentage
'
                    Range("L" & I).Value = y / Movers_Flyers * 100  'Percentage
                    objWord.ActiveDocument.Close    'close the document, word still exists
    
            End With
    
        End If 'TemplateNeeded = "EVALUATION REPORT Movers & Flyers"
        
    Next I
    
    objWord.Quit    'Close word
    Application.StatusBar = False
    
End Sub