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

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:
Attachment 20997

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

The following Word macro should work, based on your example

Code:

---

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

---

Code:

---

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

---

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:

Code:

---

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

---

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

Code:

---

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

---

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