How to find table column, then move down and replace the cell's content IF it is "N/A"

Question

I have almost 1,800 Word documents that have about 8 pages with unique data in tables. We were just informed that the data we were given for some of those tables is inaccurate and needs to be changed from "N/A" to "0.0%". As "N/A" is used a lot in the document, I unfortunately cannot just find/replace that text.

Using this thread (Macro to find in Word table for specific string in a cell and move x cell left, check isnumeric then set typography on down x cell in the same column) I was able to adjust the code below to find the column header (On-Time Completion Rate) and move to the adjacent cells to update them. However, since this column is for percentages, the IsNumeric code is changing any data it finds due to the percentage symbol.

Is there a way to do the same but instead of using IsNumeric (since it does not work for percentages) check the value in the cell and if it finds "N/A" change it to "0.0%"? This would then need to be repeated for two more tables, with one table have four rows to look through.

Thank you in advance for any help you can offer!

Screenshot of table

Sub Demo()
Application.ScreenUpdating = False
Dim r As Long, c As Long
With ActiveDocument.Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "On-time Completion Rate" 'Column Header'
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindStop
    .Format = False
    .MatchWildcards = True
    .Execute
  End With
  Do While .Find.Found
    If .Information(wdWithInTable) = True Then
      r = .Cells(1).RowIndex
      c = .Cells(1).ColumnIndex
      With .Tables(1)
             If Not IsNumeric(Split(.Cell(r + 1, c).Range.Text, vbCr)(0)) Then .Cell(r + 1, c).Range.Text = "0.0%"
        If Not IsNumeric(Split(.Cell(r + 2, c).Range.Text, vbCr)(0)) Then .Cell(r + 2, c).Range.Text = "0.0%"
      End With
    End If
    .Collapse wdCollapseEnd
    .Find.Execute
  Loop
End With
Application.ScreenUpdating = True
End Sub

Answer 1

Try this:

Sub Demo()
   Application.ScreenUpdating = False
   Dim r As Long, c As Long
   With ActiveDocument.Range
      With .Find
         .ClearFormatting
         .Replacement.ClearFormatting
         .Text = "On-time Completion Rate" 'Column Header'
         .Replacement.Text = ""
         .Forward = True
         .Wrap = wdFindStop
         .Format = False
         .MatchWildcards = True
         .Execute
      End With
      Do While .Find.Found
         If .Information(wdWithInTable) = True Then
            r = .Cells(1).RowIndex
            c = .Cells(1).ColumnIndex
            With .Tables(1)
               If Split(.Cell(r + 1, c).Range.Text, vbCr)(0) = "N/A" Then .Cell(r + 1, c).Range.Text = "0.0%"
               If Split(.Cell(r + 2, c).Range.Text, vbCr)(0) = "N/A" Then .Cell(r + 2, c).Range.Text = "0.0%"
            End With
         End If
         .Collapse wdCollapseEnd
         .Find.Execute
      Loop
   End With
   Application.ScreenUpdating = True
End Sub

Answer 2

If all instances of N/A in the tables are to be replaced, the following would be more efficient:

Sub Demo()
Application.ScreenUpdating = False
With ActiveDocument.Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "On-time Completion Rate"
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindStop
    .Format = False
    .MatchWildcards = True
    .Execute
  End With
  Do While .Find.Found
    .Duplicate.Tables(1).Range.Find.Execute FindText:="N/A", ReplaceWith:="0.0%", Wrap:=wdFindStop, Replace:=wdReplaceAll
    .Collapse wdCollapseEnd
    .Find.Execute
  Loop
End With
Application.ScreenUpdating = True
End Sub

Extending this to process a whole folder of documents, you could use code like:

Sub UpdateDocuments()
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, strDocNm As String, wdDoc As Document
strDocNm = ActiveDocument.FullName: strFolder = GetFolder
If strFolder = "" Then Exit Sub
strFile = Dir(strFolder & "\*.docx", vbNormal)
While strFile <> ""
  If strFolder & "\" & strFile <> strDocNm Then
    Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
    With wdDoc
      With .Range
        With .Find
          .ClearFormatting
          .Replacement.ClearFormatting
          .Text = "On-time Completion Rate"
          .Replacement.Text = ""
          .Forward = True
          .Wrap = wdFindStop
          .Format = False
          .MatchWildcards = True
          .Execute
        End With
        Do While .Find.Found
          .Duplicate.Tables(1).Range.Find.Execute FindText:="N/A", ReplaceWith:="0.0%", Wrap:=wdFindStop, Replace:=wdReplaceAll
          .Collapse wdCollapseEnd
          .Find.Execute
        Loop
      End With
      .Close SaveChanges:=True
    End With
  End If
  strFile = Dir()
Wend
Set wdDoc = Nothing
Application.ScreenUpdating = True
End Sub
 
Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function

To extend the code even further to process documents in sub-folders, see: https://www.msofficeforums.com/47785-post14.html

To save the updated documents as PDFs, insert:

.SaveAs FileName:=Split(.FullName, ".doc")(0) & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False

before:

.Close SaveChanges:=True