none
Replace Font Colors in List RRS feed

  • Question

  • Hi friends,

    I am trying to replace font colors in lists.

    I have made a spreadsheet

    Colum A -Word
    Red
    Green
    Blue

    Column B -Color

    0|255|0
    0|255|0
    0|0|255

    if the word is red in the list previous paragraph - all the first words will be colored red

    if the word is Green in the list previous paragraph - all the first words will be colored green etc

    End Result

    this is script - it runs but no color change

    Sub List_Words_Color_XL()
    
        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
        
        Dim oPar As Paragraph
        Dim oDoc                As Document
        Dim oRng                As Range
        
        
       
        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
        Set xlWbk = xlApp.Workbooks.Open(FileName:="C:\Users\Dan\Desktop\Replace.xlsm")
        
        Set xlWsh = xlWbk.Worksheets("RGB")
        lngLastRow = xlWsh.Range("A" & xlWsh.Rows.Count).End(-4162).Row ' -4162 = xlUp
        For lngRow = 2 To lngLastRow
        '---------------------------------------
        
    
        For Each oPar In ActiveDocument.Paragraphs
            If oPar.Range.ListFormat.ListType = wdListBullet Then
            If Not oPar.Previous.Range.ListFormat.ListType = wdListBullet Then
                
           
            If Trim(oPar.Previous.Range.Words(1)) = xlWsh.Range("A" & lngRow).Value Then
                            
           
            RGBCol = Split(xlWsh.Range("B" & lngRow).Value, "|")
            RGBFontColor = RGB(Trim(RGBCol(0)), Trim(RGBCol(1)), Trim(RGBCol(2)))
        
                            
            oPar.Range.Words(1).Font.Color = RGBFontColor
                          
            End If
                 
        
        
        End If
        End If
        Next oPar
        
        
                
        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
    
    
    
    




    please advise


    Cheers Dan

    Thursday, July 28, 2016 1:09 PM

Answers

  • I'd do the loops the other way round, to prevent having to loop through all paragraphs for eachcolor:

    • Loop once through the paragraphs.
    • If the paragraph does not have a bullet, pick up the color name from the first word. Search for the color name in column A of the worksheet (using the Find method, so that you don't need to loop). If found, get the RGB value from the corresponding cell in column B. As a safety measure, use black if we can't find the color name.
    • If the paragraph does have a bullet, apply the RGB value we picked up earlier to the first word.

    This worked OK for me in a small test document. Here is the code:

    Sub List_Words_Color_XL()
        Dim xlApp               As Object
        Dim xlWbk               As Object
        Dim xlWsh               As Object
        Dim xlCell              As Object
        Dim blnStart            As Boolean
        Dim RGBCol              As Variant
        Dim RGBFontColor        As Long
        Dim oPar                As Paragraph
        Dim sColor              As String
        
        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
        Set xlWbk = xlApp.Workbooks.Open(FileName:="C:\Users\Dan\Desktop\Replace.xlsm")
        Set xlWsh = xlWbk.Worksheets("RGB")
        
        For Each oPar In ActiveDocument.Paragraphs
            If oPar.Range.ListFormat.ListType = wdListBullet Then
                oPar.Range.Words(1).Font.Color = RGBFontColor
            Else
                sColor = Trim(oPar.Range.Words(1))
                Set xlCell = xlWsh.Range("A:A").Find(What:=sColor, LookAt:=1, MatchCase:=False)
                If xlCell Is Nothing Then
                    RGBFontColor = vbBlack
                Else
                    RGBCol = Split(xlCell.Offset(0, 1).Value, "|")
                    RGBFontColor = RGB(Trim(RGBCol(0)), Trim(RGBCol(1)), Trim(RGBCol(2)))
                End If
            End If
        Next oPar
        
    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 Dan_CS Thursday, July 28, 2016 8:16 PM
    Thursday, July 28, 2016 7:33 PM

All replies

  • I'd do the loops the other way round, to prevent having to loop through all paragraphs for eachcolor:

    • Loop once through the paragraphs.
    • If the paragraph does not have a bullet, pick up the color name from the first word. Search for the color name in column A of the worksheet (using the Find method, so that you don't need to loop). If found, get the RGB value from the corresponding cell in column B. As a safety measure, use black if we can't find the color name.
    • If the paragraph does have a bullet, apply the RGB value we picked up earlier to the first word.

    This worked OK for me in a small test document. Here is the code:

    Sub List_Words_Color_XL()
        Dim xlApp               As Object
        Dim xlWbk               As Object
        Dim xlWsh               As Object
        Dim xlCell              As Object
        Dim blnStart            As Boolean
        Dim RGBCol              As Variant
        Dim RGBFontColor        As Long
        Dim oPar                As Paragraph
        Dim sColor              As String
        
        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
        Set xlWbk = xlApp.Workbooks.Open(FileName:="C:\Users\Dan\Desktop\Replace.xlsm")
        Set xlWsh = xlWbk.Worksheets("RGB")
        
        For Each oPar In ActiveDocument.Paragraphs
            If oPar.Range.ListFormat.ListType = wdListBullet Then
                oPar.Range.Words(1).Font.Color = RGBFontColor
            Else
                sColor = Trim(oPar.Range.Words(1))
                Set xlCell = xlWsh.Range("A:A").Find(What:=sColor, LookAt:=1, MatchCase:=False)
                If xlCell Is Nothing Then
                    RGBFontColor = vbBlack
                Else
                    RGBCol = Split(xlCell.Offset(0, 1).Value, "|")
                    RGBFontColor = RGB(Trim(RGBCol(0)), Trim(RGBCol(1)), Trim(RGBCol(2)))
                End If
            End If
        Next oPar
        
    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 Dan_CS Thursday, July 28, 2016 8:16 PM
    Thursday, July 28, 2016 7:33 PM
  • Thank you very much Hans,

    I was stuck on the else for a long time and I just couldn't work out what I was meant to do.

    I thought I should just leave it as default.

    It worked nicely - :)

    Although I was testing on  the wrong bullet points - so it took me time to work out why it wasn't working  oh well

    Have a great evening


    Cheers Dan

    Thursday, July 28, 2016 8:16 PM