Finding string in Word, searching for it in Excel column - if found, replace in Word

[Cubajz]

Hi guys,
I need help with Word macro that would do this:

Find a STRING OF RED TEXT in Word Document (red strings are located at the beginning of table cells)

Search for this text in Excel column and:
- If string is found, select that Excel cell and paste its content as plain text to Word – replacing the whole cell contents in Word cell. It is important now to make this cells text BLACK in Word - or otherwise cell "catches" red color due to plain text paste.
- If string is not found, then just continue with finding next Red String of text in Word, till the end of Word document.

Pictures can make you understand it better, I think:

Picture before macro:
Before.jpg

Picture after macro:
After.jpg

Thanks for any help, I really appreciate it.

[Cubajz]

I am also attaching Excel and Word files, so you maybe have easier time doing this . Thanks

[gmaxey]

Cubajz,

What have you tried? Like anyone else, you would have an easier time if you would roll up your sleeves and make some effort at writing code. This is not a free code writing service! Generally we come here in the spirit of helping those who are trying to learn VBA. Nevertheless, here is one way that might work:

Option Explicit
Private m_arrExcelContent As Variant
Sub DoIt()
Dim strWorkbook As String
Dim lngIndex As Long
Dim oRng As Range
Dim oTbl As Table, oCell As Cell
  strWorkbook = ThisDocument.Path & "\Book1.xlsx" 'Change to suit your actual Excel path.
  If Dir(strWorkbook) = "" Then
    MsgBox "Cannot find the designated workbook: " & strWorkbook, vbExclamation
    Exit Sub
  End If
  m_arrExcelContent = fcnExcelDataToArray(strWorkbook, , , False)
  For Each oCell In ActiveDocument.Tables(1).Range.Cells
    Set oRng = oCell.Range
    With oRng.Find
      .Font.ColorIndex = wdRed
      .MatchWildcards = True
      If .Execute Then
        For lngIndex = 0 To UBound(m_arrExcelContent, 2)
          If InStr(m_arrExcelContent(0, lngIndex), Trim(oRng.Text)) > 0 Then
            With oCell
              .Range.Text = m_arrExcelContent(0, lngIndex)
              .Range.Font.ColorIndex = wdAuto
            End With
            Exit For
          End If
        Next
      End If
    End With
   Next
lbl_Exit:
  Exit Sub
End Sub
Private Function fcnExcelDataToArray(strWorkbook As String, _
    Optional strRange As String = "Sheet1", _
    Optional bIsSheet As Boolean = True, _
    Optional bHeaderRow As Boolean = True) As Variant
     'Default parameters include "Sheet1" as the named sheet, range of the full named sheet and a header row is used.
    Dim oRS As Object, oConn As Object
    Dim lngRows As Long
    Dim strHeaderYES_NO As String
    strHeaderYES_NO = "YES"
    If Not bHeaderRow Then strHeaderYES_NO = "NO"
    If bIsSheet Then strRange = strRange & "$]" Else strRange = strRange & "]"
    Set oConn = CreateObject("ADODB.Connection")
    oConn.Open ConnectionString:="Provider=Microsoft.ACE.OLEDB.12.0;" & _
    "Data Source=" & strWorkbook & ";" & _
    "Extended Properties=""Excel 12.0 Xml;HDR=" & strHeaderYES_NO & """;"
    Set oRS = CreateObject("ADODB.Recordset")
    oRS.Open "SELECT * FROM [" & strRange, oConn, 2, 1
    With oRS
        .MoveLast
        lngRows = .RecordCount
        .MoveFirst
    End With
    fcnExcelDataToArray = oRS.GetRows(lngRows)
lbl_Exit:
    If oRS.State = 1 Then oRS.Close
    Set oRS = Nothing
    If oConn.State = 1 Then oConn.Close
    Set oConn = Nothing
    Exit Function
End Function

[Cubajz]

Because of your help with my previous posts I already did wrote few very simple macros for this project of mine - and did some other work thanks to previous posts. I of course intend to continue learning VBA. I am beginner to this, but I am already better then few months before, all thanks to your posts and me trying to applicate them
I absolutely understand that good people put their time and energy replying my posts, writing code...and they dont have to.. - so again big thanks for your help and in the future I will try harder on my own.
Your code above works perfectly.

[Cubajz]

I need to ask for help: I now have document with multiple tables in it and I am using this solution which is very far from elegant : I Just changed the first line of code with .Tables(1) then .Tables(2) .Tables(3) etc ..

For Each oCell In ActiveDocument.Tables(1).Range.Cells
        Set oRng = oCell.Range
        With oRng.Find
            .Font.ColorIndex = wdRed
            .MatchWildcards = True
            If .Execute Then
                For lngIndex = 0 To UBound(m_arrExcelContent, 2)
                    If InStr(m_arrExcelContent(0, lngIndex), Trim(oRng.Text)) > 0 Then
                        With oCell
                            .Range.Text = m_arrExcelContent(0, lngIndex)
                            .Range.Font.ColorIndex = wdAuto
                        End With
                        Exit For
                    End If
                Next
            End If
        End With
    Next
    
    For Each oCell In ActiveDocument.Tables(2).Range.Cells
        Set oRng = oCell.Range
        With oRng.Find
            .Font.ColorIndex = wdRed
            .MatchWildcards = True
            If .Execute Then
                For lngIndex = 0 To UBound(m_arrExcelContent, 2)
                    If InStr(m_arrExcelContent(0, lngIndex), Trim(oRng.Text)) > 0 Then
                        With oCell
                            .Range.Text = m_arrExcelContent(0, lngIndex)
                            .Range.Font.ColorIndex = wdAuto
                        End With
                        Exit For
                    End If
                Next
            End If
        End With
    Next


...

Is there an easy way to edit macro so it would go through every table in document? Thank you guys

[gmaxey]

Sub Example_fcnCompleteTableCollection()
Dim oTbl As Table
  For Each oTbl In fcnCompleteTableCollection
    Debug.Print oTbl.NestingLevel
    'Put your functioning code here.
  Next
lbl_Exit:
  Exit Sub
End Sub
Function fcnCompleteTableCollection(Optional ByVal oDoc As Document) As Collection
'Returns all tables (top level and nested) in one collection.
Dim colStack As New Collection
Dim oTbl As Table
  Set fcnCompleteTableCollection = New Collection
  If Documents.Count > 0 And oDoc Is Nothing Then
    Set oDoc = ActiveDocument
  Else
    GoTo lbl_Exit
  End If
  colStack.Add oDoc.Tables
  Do While colStack.Count > 0
    For Each oTbl In colStack(1)
      fcnCompleteTableCollection.Add oTbl
      If oTbl.Tables.Count > 0 Then colStack.Add oTbl.Tables
    Next
    colStack.Remove 1
  Loop
lbl_Exit:
  Exit Function
End Function

[Cubajz]

So I tried to stich it together, but unfortunately can´t make it to work...No errors or anything, but it doesn´t do what it should. I tryed to work on it, but can´t figure this out. Maybe there are some problems in the beggining..(For Each...) What I did wrong? Thanks in advance for your help.

Option ExplicitPrivate m_arrExcelContent As Variant
Sub DoIt()
    Dim strWorkbook As String
    Dim lngIndex As Long
    Dim oRng As Range
    Dim oTbl As Table, oCell As Cell
    strWorkbook = "U:\Předpisy a normy po oblastech.xlsx" 'Change to suit your actual Excel path.
    
    m_arrExcelContent = fcnExcelDataToArray(strWorkbook, , , False)
    
For Each oTbl In fcnCompleteTableCollection
        Debug.Print oTbl.NestingLevel
  For Each oCell In ActiveDocument.Tables(1).Range.Cells
    Set oRng = oCell.Range
    With oRng.Find
        .Font.ColorIndex = wdRed
        .MatchWildcards = True
        If .Execute Then
            For lngIndex = 0 To UBound(m_arrExcelContent, 2)
                If InStr(m_arrExcelContent(0, lngIndex), Trim(oRng.Text)) > 0 Then
                    With oCell
                        .Range.Text = m_arrExcelContent(0, lngIndex)
                        .Range.Font.ColorIndex = wdAuto
                    End With
                    Exit For
                End If
            Next
        End If
    End With
  Next
Next
lbl_Exit:
    Exit Sub
End Sub

Function fcnCompleteTableCollection(Optional ByVal oDoc As Document) As Collection
     'Returns all tables (top level and nested) in one collection.
    Dim colStack As New Collection
    Dim oTbl As Table
    Set fcnCompleteTableCollection = New Collection
    If Documents.Count > 0 And oDoc Is Nothing Then
        Set oDoc = ActiveDocument
    Else
        GoTo lbl_Exit
    End If
    colStack.Add oDoc.Tables
    Do While colStack.Count > 0
        For Each oTbl In colStack(1)
            fcnCompleteTableCollection.Add oTbl
            If oTbl.Tables.Count > 0 Then colStack.Add oTbl.Tables
        Next
        colStack.Remove 1
    Loop
lbl_Exit:
    Exit Function
End Function
 
 
Private Function fcnExcelDataToArray(strWorkbook As String, _
    Optional strRange As String = "Předpisy a normy po oblastech", _
    Optional bIsSheet As Boolean = True, _
    Optional bHeaderRow As Boolean = True) As Variant
     'Default parameters include "Sheet1" as the named sheet, range of the full named sheet and a header row is used.
    Dim oRS As Object, oConn As Object
    Dim lngRows As Long
    Dim strHeaderYES_NO As String
    strHeaderYES_NO = "YES"
    If Not bHeaderRow Then strHeaderYES_NO = "NO"
    If bIsSheet Then strRange = strRange & "$]" Else strRange = strRange & "]"
    Set oConn = CreateObject("ADODB.Connection")
    oConn.Open ConnectionString:="Provider=Microsoft.ACE.OLEDB.12.0;" & _
    "Data Source=" & strWorkbook & ";" & _
    "Extended Properties=""Excel 12.0 Xml;HDR=" & strHeaderYES_NO & """;"
    Set oRS = CreateObject("ADODB.Recordset")
    oRS.Open "SELECT * FROM [" & strRange, oConn, 2, 1
    With oRS
        .MoveLast
        lngRows = .RecordCount
        .MoveFirst
    End With
    fcnExcelDataToArray = oRS.GetRows(lngRows)
lbl_Exit:
    If oRS.State = 1 Then oRS.Close
    Set oRS = Nothing
    If oConn.State = 1 Then oConn.Close
    Set oConn = Nothing
    Exit Function
End Function

[gmaxey]

We are not dealing with For Each oCell In ActiveDocument.Tables(1).Range.Cells anymore, we are dealing with

For Each oCell In oTbl.Range.Cells

[Cubajz]

Thank you, now it works.