none
VBA Excel Color Array To Apply to Words RRS feed

  • Question

  • Hello,

    I am searching in a word documents for specific words that are in an exel sheet - they have a RGB color associated with them.

    List of words are in Excel column E, in Column F there is an RGB color that I need to apply to the word.


    Example Excel Sheet

    Word  (E)           RGB (F)
    Q1839              71,60,139
    V38474            0 ,238 ,0
    S2873              238 ,58 ,140
    ....
    ...

    The list gets added and updated  as time goes on.


    I have found this thread it does the basic task of finding and replacing words in word documents.

    https://social.msdn.microsoft.com/Forums/en-US/036db2ef-25c9-4c8c-85bd-03084519540f/find-and-replace-in-word-from-a-table-in-excel?forum=isvvba


    I have declared an Array for the RGB colors

    Dim RGBFont as Variant

    Dim RGBCol as Variant

    RGBCol = Split(Arr(6, i), ",")

    RGBFontColor = RGB(RGBCol(1), RGBCol(2), RGBCol(3))        

    I am not sure how to put them together now, and have been on this problem for a few days.

     .Text = xlWsh.Range("E" & lngRow).Value
     .Replacement.Text .font.color= xlWsh.Range("F" & lngRow).Value

    Please advise thank you very much

    may

                        
    Thursday, June 23, 2016 2:17 PM

Answers

  • Split produces a zero-based array, so you should start at RGBCol(0).

    Here is some code based on that in the topic you refer to:

    Sub MultiReplace()
        Dim xlApp As Object
        Dim xlWbk As Object
        Dim xlWsh As Object
        Dim blnStart As Boolean
        Dim lngRow As Long
        Dim lngLastRow As Long
        Dim RGBCol As Variant
        Dim RGBFontColor As Long
        On Error Resume Next
        Set xlApp = GetObject(Class:="Excel.Application")
        If xlApp Is Nothing Then
            Set xlApp = CreateObject(Class:="Excel.Application")
            If xlApp Is Nothing Then
                MsgBox "Failed to start Excel", vbExclamation
                Exit Sub
            End If
            blnStart = True
        End If
        On Error GoTo ErrHandler
        Application.ScreenUpdating = False
        ' Open workbook - substitute correct path and filename to Excel workbook
        Set xlWbk = xlApp.Workbooks.Open(FileName:="C:\Excel\Concordance.xlsx")
        ' Reference to worksheet - substitute correct sheet number or name
        Set xlWsh = xlWbk.Worksheets(1)
        ' Find last row
        lngLastRow = xlWsh.Range("E" & xlWsh.Rows.Count).End(-4162).Row ' -4162 = xlUp
        ' Start at row 2 - adjust if necessary
        For lngRow = 2 To lngLastRow
            Selection.HomeKey Unit:=wdStory
            With Selection.Find
                .Text = xlWsh.Range("E" & lngRow).Value
                RGBCol = Split(xlWsh.Range("F" & lngRow).Value, ",")
                RGBFontColor = RGB(Trim(RGBCol(0)), Trim(RGBCol(1)), Trim(RGBCol(2)))
                .Replacement.Font.Color = RGBFontColor
                .Forward = True
                .Wrap = wdFindContinue
                .Format = True
                .MatchCase = False
                .MatchWholeWord = False
                .MatchWildcards = False
                .MatchSoundsLike = False
                .MatchAllWordForms = False
                .Execute Replace:=wdReplaceAll
            End With
        Next lngRow
    ExitHandler:
        On Error Resume Next
        xlWbk.Close SaveChanges:=False
        If blnStart Then
            xlApp.Quit
        End If
        Application.ScreenUpdating = True
        Exit Sub
    ErrHandler:
        MsgBox Err.Description, vbExclamation
        Resume ExitHandler
    End Sub


    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    • Marked as answer by mabbott5 Thursday, June 23, 2016 6:50 PM
    Thursday, June 23, 2016 5:14 PM

All replies

  • Split produces a zero-based array, so you should start at RGBCol(0).

    Here is some code based on that in the topic you refer to:

    Sub MultiReplace()
        Dim xlApp As Object
        Dim xlWbk As Object
        Dim xlWsh As Object
        Dim blnStart As Boolean
        Dim lngRow As Long
        Dim lngLastRow As Long
        Dim RGBCol As Variant
        Dim RGBFontColor As Long
        On Error Resume Next
        Set xlApp = GetObject(Class:="Excel.Application")
        If xlApp Is Nothing Then
            Set xlApp = CreateObject(Class:="Excel.Application")
            If xlApp Is Nothing Then
                MsgBox "Failed to start Excel", vbExclamation
                Exit Sub
            End If
            blnStart = True
        End If
        On Error GoTo ErrHandler
        Application.ScreenUpdating = False
        ' Open workbook - substitute correct path and filename to Excel workbook
        Set xlWbk = xlApp.Workbooks.Open(FileName:="C:\Excel\Concordance.xlsx")
        ' Reference to worksheet - substitute correct sheet number or name
        Set xlWsh = xlWbk.Worksheets(1)
        ' Find last row
        lngLastRow = xlWsh.Range("E" & xlWsh.Rows.Count).End(-4162).Row ' -4162 = xlUp
        ' Start at row 2 - adjust if necessary
        For lngRow = 2 To lngLastRow
            Selection.HomeKey Unit:=wdStory
            With Selection.Find
                .Text = xlWsh.Range("E" & lngRow).Value
                RGBCol = Split(xlWsh.Range("F" & lngRow).Value, ",")
                RGBFontColor = RGB(Trim(RGBCol(0)), Trim(RGBCol(1)), Trim(RGBCol(2)))
                .Replacement.Font.Color = RGBFontColor
                .Forward = True
                .Wrap = wdFindContinue
                .Format = True
                .MatchCase = False
                .MatchWholeWord = False
                .MatchWildcards = False
                .MatchSoundsLike = False
                .MatchAllWordForms = False
                .Execute Replace:=wdReplaceAll
            End With
        Next lngRow
    ExitHandler:
        On Error Resume Next
        xlWbk.Close SaveChanges:=False
        If blnStart Then
            xlApp.Quit
        End If
        Application.ScreenUpdating = True
        Exit Sub
    ErrHandler:
        MsgBox Err.Description, vbExclamation
        Resume ExitHandler
    End Sub


    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    • Marked as answer by mabbott5 Thursday, June 23, 2016 6:50 PM
    Thursday, June 23, 2016 5:14 PM
  • Thank you my dear Hans,

    that worked absolutely beautifully.

    I was a bit stubborn not to ask for help,  but as a clueless newbie i was going around in circles

    but that solved the problem very nicely

    thank you again for your great code, i can start my coloring work 

    May 

    Thursday, June 23, 2016 6:50 PM