Macro for making data found in Excel column RED in a Word document

[Cubajz]

Hi,

as a beginer I need to ask for help with this macro:

I have column in EXCEL - each cell is populated with data (or some are empty). I also have a long document in WORD.
I need a macro that would go through each cell in EXCEL column, copy data, and than made all data which it founds in WORD document RED - so it stands out and I can easily spot it in document.

and I also need macro to skip blank cells in EXCEL.


Picture shows the result I want to achieve:
20997

Thank for any advice. https://www.excelforum.com/images/smilies/smile.gif

[gmayor]

The following Word macro should work, based on your example


Option Explicit

Sub ColourValues()
'Graham Mayor - http://www.gmayor.com - Last updated - 21 Nov 2017
Const strWorkbook As String = "C:\Path\WorkbookName.xlsx"
Const strSheet As String = "Sheet1"
Dim Arr() As Variant
Dim iCols As Long
Dim oRng As Range
Dim sFind As String
On Error Resume Next
Arr = xlFillArray(strWorkbook, strSheet)
For iCols = 0 To UBound(Arr)
sFind = Arr(3, iCols)
Set oRng = ActiveDocument.Range
With oRng.Find
Do While .Execute(FindText:=sFind)
oRng.Font.ColorIndex = wdRed
oRng.Collapse 0
Loop
End With
Next iCols
lbl_Exit:
Set oRng = Nothing
Exit Sub
End Sub


Private Function xlFillArray(strWorkbook As String, _
strRange As String) As Variant
'Graham Mayor - http://www.gmayor.com - 24/09/2016
Dim RS As Object
Dim CN As Object
Dim iRows As Long

strRange = strRange & "$]" 'Use this to work with a named worksheet
'strRange = strRange & "]" 'Use this to work with a named range
Set CN = CreateObject("ADODB.Connection")

'Set HDR=NO for no header row
CN.Open ConnectionString:="Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & strWorkbook & ";" & _
"Extended Properties=""Excel 12.0 Xml;HDR=YES"";"

Set RS = CreateObject("ADODB.Recordset")
RS.Open "SELECT * FROM [" & strRange, CN, 2, 1

With RS
.MoveLast
iRows = .RecordCount
.MoveFirst
End With
xlFillArray = RS.GetRows(iRows)
If RS.State = 1 Then RS.Close
Set RS = Nothing
If CN.State = 1 Then CN.Close
Set CN = Nothing
lbl_Exit:
Exit Function
End Function

[gmaxey]

Option Explicit
Const strXLFile = "D:\Data Stores\Find and Replace List.xlsx" 'Change to define your path.
Sub ScratchMacro()
'A basic Word macro coded by Greg Maxey, http://gregmaxey.com/word_tips.html, 11/21/2017
Dim oXLApp As Object
Dim oXLWbk As Object
Dim oXLWsh As Object
Dim bStartXL As Boolean
Dim lngIndex As Long, lngRows As Long
Dim oRng As Word.Range

On Error Resume Next
'Get or start Excel
Set oXLApp = GetObject(, "Excel.Application")
If oXLApp Is Nothing Then
Set oXLApp = CreateObject("Excel.Application")
If oXLApp Is Nothing Then
MsgBox "Can't start Excel.", vbExclamation
Exit Sub
End If
bStartXL = True
End If
On Error GoTo ErrHandler
Application.ScreenUpdating = False
'Open workbook
Set oXLWbk = oXLApp.Workbooks.Open(strXLFile)
'Reference to first worksheet
Set oXLWsh = oXLWbk.Worksheets(1)
'Get last used row
lngRows = oXLWsh.Cells(oXLWsh.Rows.Count, 1).End(-4162).Row 'Change 1 to whatever you column index is.
For lngIndex = 1 To lngRows
Set oRng = ActiveDocument.Range
With oRng.Find
.ClearFormatting
.MatchCase = True
.MatchWholeWord = True
.MatchWildcards = False
.Text = oXLWsh.Cells(lngIndex, 1) 'Change 1 to whatever you column index is.
With .Replacement
.Font.ColorIndex = wdRed
.Text = "^&"
End With
.Execute Replace:=wdReplaceAll
End With
Next lngIndex
lbl_Exit:
'Clean up
On Error Resume Next
Set oXLWsh = Nothing
oXLWbk.Close savechanges:=False
Set oXLWbk = Nothing
If bStartXL Then oXLApp.Quit
Set oXLApp = Nothing
Application.ScreenUpdating = True
Exit Sub
ErrHandler:
Select Case Err.Number
Case Else
'Inform user
MsgBox Err.Description, vbExclamation
Resume lbl_Exit
End Select
End Sub

[gmaxey]

Graham's process will be faster because he is using ADODB (not physically starting the Excel application). However, you will need to revise it a bit as it will only process part of your column if you have more rows than columns. Here is a revision that would work:


Sub ColourValues()
'Original by Graham Mayor. Modified by Greg Maxey
Const strWorkbook As String = "D:\Data Stores\Find and Replace List.xlsx" 'Change to your path.
Const strSheet As String = "Sheet1"
Dim varArr() As Variant
Dim lngCols As Long
Dim oRng As Range
On Error Resume Next
varArr = xlFillvarArray(strWorkbook, strSheet)
For lngCols = 0 To UBound(varArr, 2)
Set oRng = ActiveDocument.Range
With oRng.Find
.Text = varArr(0, lngCols) 'Change 0 to whatever your Excel colummn index is minus 1.
With .Replacement
.Font.ColorIndex = wdRed
.Text = "^&"
End With
.Execute Replace:=wdReplaceAll
End With
Next lngCols
lbl_Exit:
Set oRng = Nothing
Exit Sub
End Sub

[Cubajz]

Thank you soo much both! It works like a charm with a revision implemented in code. :bow:

(with testing i found little mistake in revision - line num. 9):

varArr = xlFillvarArray(strWorkbook, strSheet)

should be just this, for combined codes to work:
varArr = xlFillArray(strWorkbook, strSheet)


So, for anybody else who might want to use this, there is combined code from vba masters in one piece :clap::

Option Explicit
Sub ColourValues()
'Original by Graham Mayor. Modified by Greg Maxey
Const strWorkbook As String = "C:\Users\skopa\Desktop\Předpisy a normy po oblastech.xlsm" 'Change to your path.
Const strSheet As String = "Sheet1"
Dim varArr() As Variant
Dim lngCols As Long
Dim oRng As Range
On Error Resume Next
varArr = xlFillArray(strWorkbook, strSheet)
For lngCols = 0 To UBound(varArr, 2)
Set oRng = ActiveDocument.Range
With oRng.Find
.Text = varArr(0, lngCols) 'Change 0 to whatever your Excel colummn index is minus 1.
With .Replacement
.Font.ColorIndex = wdBlue
.Text = "^&"
End With
.Execute Replace:=wdReplaceAll
End With
Next lngCols
lbl_Exit:
Set oRng = Nothing
Exit Sub
End Sub


Private Function xlFillArray(strWorkbook As String, _
strRange As String) As Variant
'Graham Mayor - http://www.gmayor.com - 24/09/2016
Dim RS As Object
Dim CN As Object
Dim iRows As Long

strRange = strRange & "$]" 'Use this to work with a named worksheet
'strRange = strRange & "]" 'Use this to work with a named range
Set CN = CreateObject("ADODB.Connection")

'Set HDR=NO for no header row
CN.Open ConnectionString:="Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & strWorkbook & ";" & _
"Extended Properties=""Excel 12.0 Xml;HDR=YES"";"

Set RS = CreateObject("ADODB.Recordset")
RS.Open "SELECT * FROM [" & strRange, CN, 2, 1

With RS
.MoveLast
iRows = .RecordCount
.MoveFirst
End With
xlFillArray = RS.GetRows(iRows)
If RS.State = 1 Then RS.Close
Set RS = Nothing
If CN.State = 1 Then CN.Close
Set CN = Nothing
lbl_Exit:
Exit Function
End Function

[gmaxey]

A pitfall of careless find and replace. Thanks for posting it correctly.