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

Picture after macro:
21046

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 :think:. 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 :doh:: 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:dunno? Thanks in advance for your help.:bow:

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