Using Excel VBA to Find Empty Table Cells in Word Documents

[johnodocs]

Hi Guys

Let me first say I am not an advanced user with VBA but have always seemed to get along by trial and error but this week I have come undone and would be grateful for some help.

Here is the background. I have a spreadsheet with 1,500 rows that link to Parent Reports that out teachers' have done in Word Documents. Normally it is an administrators job to check all these and see if a teacher has left any cells blank in the tables within the document, meaning that it is incomplete - a horrible job but a necessary job.

I've been working with some code from here:Detect whether a table cell is empty

So far I have been able to get to the point when Excel opens the word document but it all unravels there. Also I get the error "The remote server machine does not exist or isn't available"

Any help would be greatly appreciated and of course let me know if you need more information


******

Sub ThemeBlankBox()

Dim Path As String
Dim objDoc As Word.Document
Dim objWord As Word.Application
Dim oCell As cell
Dim oRow As Row

Sheets("Data").Select
FinalRow = Range("A9999").End(xlUp).Row

For I = 2 To FinalRow

Path = Sheets("Data").Range("H" & I).Text


Set objWord = CreateObject("Word.Application")
Set objDoc = objWord.Documents.Open(Path)

objWord.Visible = True

With objDoc
For Each oRow In ActiveDocument.Tables(1).Rows ' this is where the error appears when running line by line (F8)
For Each oCell In oRow.Cells
If oCell.Range.Text = Chr(13) & Chr(7) Then
Range("K" & I).Value = "Empty Cells Present"

Else

Range("K" & I).Value = "Complete"
End If
Next oCell
Next oRow

End With

Next I

objWord.ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges
objWord.Quit

End Sub

****

 

[Fennek]

Hi,

it is just a hint:

This code in word looks for empty cells:

Sub Read_Tab()
For i = 1 To ActiveDocument.Tables.Count
    For Each c In ActiveDocument.Tables(i).Range.Cells
        Tx = Left(c.Range.Text, Len(c.Range.Text) - 2)
        Debug.Print Tx
        If Tx = "" Then MsgBox "here"
    Next c
Next i
End Sub

regards

 

[johnodocs]

Any more helpers out there? I'm still a bit stuck

 

[NdNoviceHlp]

So if U find 1 blank cell in any table of a doc then U want it to notify U? Anyways, it's a blizzard outdoors and I'm bored. Trial this. Seems like it should work. Dave

Option Explicit
Sub ThemeBlankBox()
Dim DocPath As String, objDoc As Object, objWord As Object
Dim Row As Integer, Col As Integer, I As Integer
Dim FinalRow As Integer, DocNumber As Integer
'loops through documents paths in Sheet "Data" H2:H FinalRow
'loops through doc tables
'if blank table cell found inserts "Empty Cells Present" in "K"
'if no blank table cell found inserts "Complete" in "K"

FinalRow = Sheets("Data").Range("H9999").End(xlUp).Row
On Error GoTo FixIt
Set objWord = CreateObject("Word.Application")
'loop docs
For DocNumber = 2 To FinalRow
DocPath = Sheets("Data").Range("H" & DocNumber).Text
Set objDoc = objWord.Documents.Open(Filename:=DocPath)
With objDoc
'loop tables
For I = 1 To .Tables.Count
With .Tables(I)
For Row = 1 To .Rows.Count
For Col = 1 To .Columns.Count
If .cell(Row, Col).Range.Text = Chr(13) & Chr(7) Then
Sheets("Data").Range("K" & DocNumber).Value = "Empty Cells Present"
'exit doc
GoTo below
End If
Next Col
Next Row
End With
Sheets("Data").Range("K" & DocNumber).Value = "Complete"
below:
Next I
.Close SaveChanges:=False
End With
Next DocNumber
'tidy up
objWord.Quit
Set objDoc = Nothing
Set objWord = Nothing
Exit Sub
'error stuff
FixIt:
On Error GoTo 0
MsgBox "Error"
objWord.Quit
Set objDoc = Nothing
Set objWord = Nothing
End Sub

ps. Late binding is used. So no need to set a reference to the Word library.

 

[NdNoviceHlp]

That wasn't quite right. The "below:" was in the wrong spot. This is better. Dave

Option Explicit
Sub ThemeBlankBox()
Dim DocPath As String, objDoc As Object, objWord As Object
Dim Row As Integer, Col As Integer, I As Integer
Dim FinalRow As Integer, DocNumber As Integer
'loops through documents paths in Sheet "Data" H2:H FinalRow
'loops through doc tables
'if blank table cell found inserts "Empty Cells Present" in "K"
'if no blank table cell found inserts "Complete" in "K"

FinalRow = Sheets("Data").Range("H9999").End(xlUp).Row
On Error GoTo FixIt
Set objWord = CreateObject("Word.Application")

'loop docs
For DocNumber = 2 To FinalRow
'DocPath = "D:\tabletest.doc"
DocPath = Sheets("Data").Range("H" & DocNumber).Text
Set objDoc = objWord.Documents.Open(Filename:=DocPath)
With objDoc
'loop tables
For I = 1 To .Tables.Count
With .Tables(I)
For Row = 1 To .Rows.Count
For Col = 1 To .Columns.Count
If .cell(Row, Col).Range.Text = Chr(13) & Chr(7) Then
Sheets("Data").Range("K" & DocNumber).Value = "Empty Cells Present"
'exit doc
GoTo below
End If
Next Col
Next Row
End With
Next I
Sheets("Data").Range("K" & DocNumber).Value = "Complete"
below:
.Close SaveChanges:=False
End With
Next DocNumber

'tidy up
objWord.Quit
Set objDoc = Nothing
Set objWord = Nothing
Exit Sub

'error stuff
FixIt:
On Error GoTo 0
MsgBox "Error"
objWord.Quit
Set objDoc = Nothing
Set objWord = Nothing
End Sub

 

[johnodocs]

Hey,

Thanks for this. I'll try it and let you know.

John

 

[johnodocs]

This worked a charm! I really appreciate your help!

 

[NdNoviceHlp]

You are Welcome! Thanks for posting your outcome. Dave

 

[johnodocs]

I spoke to soon

After running it on the larger data set it gets passed 95 records and then I get an error "The requested member of the collection does not exist".

Seems it doesn't like the file it is working on.

Any ideas?

 

[Macropod]

Try:

Sub ReportTableBlanks()
Application.ScreenUpdating = False
Dim objWord As Object, objDoc As Object
Dim r As Long, t As Long, c As Long
Dim xlSht As Worksheet, StrRpt As String
'loops through documents paths in "Data" Sheet, Column H
'if document not found inserts "File not found" in Column K
'loops through doc tables
'if blank table cell found inserts "Empty Cells Present" in Column K
'if no blank table cell found inserts "Complete" in Column K
Set xlSht = Sheets("Data")
Set objWord = CreateObject("Word.Application")

With objWord
  'loop docs
  For r = 2 To xlSht.Range("H9999").End(xlUp).Row
    If Dir(Sheets("Data").Range("H" & r).Text, vbNormal) = "" Then
      xlSht.Range("K" & r).Value = "File not found"
    Else
      Set objDoc = .Documents.Open(Sheets("Data").Range("H" & r).Text, False, True, False)
      With objDoc
        StrRpt = ""
        'loop tables
        For t = 1 To .Tables.Count
          With .Tables(t).Range
            For c = 1 To .Cells.Count
              If Len(.Cells(c).Range.Text) = 2 Then
                StrRpt = StrRpt & " " & t
                Exit For
              End If
            Next
          End With
        Next
        If StrRpt <> "" Then
          xlSht.Range("K" & r).Value = "Empty cell(s) found in table(s)" & StrRpt
        Else
          xlSht.Range("K" & r).Value = "Complete"
        End If
        .Close False
      End With
    End If
  Next
  .Quit
End With
Set objDoc = Nothing: Set objWord = Nothing: Set xlSht = Nothing
Application.ScreenUpdating = True
End Sub