VBA - Update Paragraph Background Colors - Stored in a Table

[saphire99]

Hello to all,

I hope every one is having a great January and a great Friday too.

I have come back to ask for some help.

I am at crossroads with this problem so I thought I would ask - otherwise I will be stuck like post man Pat, slowly but surely updating the wrong colors.

I will say that I don't know if its possible to solve my problem. I have been looking but I have not found anything to help me.

The disastrous Problem:

I have lots of documents that have lots of colors - like a Kaleidoscope I would say.

Edit Paragraphs With Background Color Below	After Edited - New Updated Paragraph Background Color - Will be
Navy Blue RGB (0,0,255)	Purple* RGB (128,0,128)
Aqua RGB (0,176,240)	purple 1 RGB(155,48,255)
Blue RGB (100,100,250)	purple 2 RGB (145,44,238)

When the paragraphs have been edited and finished - they will need a new paragraph background color applied to it as per a specific color system.


I know how to do them one by one with a macro, my secret, otherwise yes I have to manually change the color with the word RGB palette - which does not always go as planned.

Dim oPara As Paragraph
For Each oPara In ActiveDocument.Paragraphs
    
If oPara.Range.Shading.BackgroundPatternColor = RGB RGB (100,100,250)   Then
  oPara.Range.Shading.BackgroundPatternColor = RGB (128,0,128)

However the problem is I am a very visual person and oops - I have been misplacing all the colors and messing up the documents.

I once applied the wrong color to 30 documents - then I couldn't find the RGB color that I originally replaced as some one deleted the VBA module, and then another color got replaced - so it turned into a case of the mysterious missing text and colors.

Now that's more work for me to fix, which took hours and hours.

I thought maybe I could have my table and that way I wont misplace the colors Or maybe I could store the colors in the table - would that work?

image.jpg


I am very sad as I tried to code for the past 5 days for hours - but nothing, I don't know what else to do?

so I must hope for some help from the very expert and kind people who know the VBA better than me by a million percent.

Sub UpdateParagraphColors()

 Dim myDoc As Document
 Dim myTable As Table
 Dim ParagraphColor As Range

 Dim FindColor As Range
 Dim ReplacementColor As Range
 Dim i As Long    ' For the table

 Dim myFilename As String

 ' Open this file that has my table of colors and use it to find and replace
 
 myFilename = "C:\Users\Saphire\Desktop\UpdateParagraphColors.docx"
 
 Set myDoc = ActiveDocument


 Set myTable = UpdateRanges.Tables(1)

 For i = 1 To myTable.Rows.Count
     Set ParagraphColor = myDoc.Range


  Set FindColor = myTable.Cell(i, 1).Range

 Set ReplacementColor = myTable.Cell(i, 2).Range


  With ParagraphColor.Find
      
             .Findcolor = myTable.Cell(i, 1)
             .Replacement.backgroundcolor = myTable.Cell(i, 2).Replacement.color


             .Execute Replace:=wdReplaceAll
       End With

 Next i     ' Color to find

 
End Sub

I referenced this thread http://stackoverflow.com/questions/3...replace-tables and also many others - that had something to do with a table, as you can imagine it can be very confusing



Is it possible for me to store my colors in a table - or the RGB values and then update in one go?

That would stop me from messing up and applying all the wrong colors to the wrong paragraphs. Also manually finding the colors again is a very tedious process.

I really am hoping for a miracle solution - there is like 73 different colors to find and 73 replacement colors - and some more in the future - you can imagine how stressful that is.

If any person would be so kind to help me I would be so very very grateful and happy.

Thank you so much for your time in looking at this disastrous problem.


Saphire


Also thank you very much for the other VBA modules - I am happy to report they are working so wonderfully, and I use them everyday!

[gmayor]

I suspect the following is what you require, however don't have unused rows in the table as in the case of your last two rows:

Option Explicit
Sub UpdateParagraphColors()
Dim myDoc As Document
Dim TableDoc As Document
Dim myTable As Table
Dim oRng As Range
Dim FindColor As Long
Dim ReplacementColor As Long
Dim i As Long        ' For the table
Dim myFilename As String

    ' Open this file that has my table of colors and use it to find and replace
    myFilename = "C:\Users\Saphire\Desktop\UpdateParagraphColors.docx"

    Set myDoc = ActiveDocument
    Set oRng = myDoc.Range
    Set TableDoc = Documents.Open(Filename:=myFilename, Visible:=False)
    Set myTable = TableDoc.Tables(1)
    For i = 2 To myTable.Rows.Count        'Omit the header row
        FindColor = myTable.Cell(i, 1).Shading.BackgroundPatternColor
        ReplacementColor = myTable.Cell(i, 2).Shading.BackgroundPatternColor
        With oRng.Find
            .Font.Shading.BackgroundPatternColor = FindColor
            Do While .Execute
                oRng.Select
                oRng.Font.Shading.BackgroundPatternColor = ReplacementColor
            Loop
        End With
    Next i
    TableDoc.Close wdDoNotSaveChanges
lbl_Exit:
    Exit Sub
End Sub

[saphire99]

Hello Graham,

I hope you are having a great Saturday!

Thank you so much for coming to help me again.

This looks like exactly what I was trying to achieve.

I need to pay attention now - last time I didn't follow instructions and spent half a day doing the wrong thing.

Test File

1.jpg


Table in

UpdateParagraphColors.docx

2.png


I run the macro - nothing changed

I deleted the text in the table apart from the header row - and nothing changed.

Thank you for helping me this Saturday

Saphire

[gmayor]

The macro works with front shading. It looks like you have something different. Can you upload copies of the two documents so that we can see exactly what we have to work with.
If no-one picks it up in the meantime, I will look at it again tomorrow (different time zone).

[saphire99]

Dear Graham,

thank you so much for your time and trouble shooting for me.


ParagraphBackgroundTest.docx


UpdateParagraphColors.docx

I hope you will have a great Saturday.

I hope not to trouble you too much

Saphire

[gmayor]

The code needs a couple of minor changes

Sub UpdateParagraphColors()
Dim myDoc As Document
Dim TableDoc As Document
Dim myTable As Table
Dim oRng As Range
Dim FindColor As Long
Dim ReplacementColor As Long
Dim i As Long        ' For the table
Dim myFilename As String

    ' Open this file that has my table of colors and use it to find and replace
    myFilename = "C:\Users\Saphire\Desktop\UpdateParagraphColors.docx"
    Set myDoc = ActiveDocument
    Set oRng = myDoc.Range
    Set TableDoc = Documents.Open(Filename:=myFilename, Visible:=False)
    Set myTable = TableDoc.Tables(1)
    For i = 2 To myTable.Rows.Count        'Omit the header row
        FindColor = myTable.Cell(i, 1).Shading.BackgroundPatternColor
        ReplacementColor = myTable.Cell(i, 2).Shading.BackgroundPatternColor
        With oRng.Find
            .ParagraphFormat.Shading.BackgroundPatternColor = FindColor
            Do While .Execute
                oRng.ParagraphFormat.Shading.BackgroundPatternColor = ReplacementColor
                oRng.Collapse 0
            Loop
        End With
    Next i
    TableDoc.Close wdDoNotSaveChanges
lbl_Exit:
    Exit Sub
End Sub

[saphire99]

Hello Graham,

thank you so much for fixing this issue.

We are nearly there.

The first color it finds it replaces it completely.

The second color - it replaces only the second time it finds the paragraph

The third color - no change.

I have been careful to set the exact color.

I am not sure why the random quirk - is it word - I will set the colors programmatically later for more testing.

I am relieved that it it working.

Would you be so kind enough to run the test to let me know


Paragraph Test.docx

UpdateParagraphColors.docx


Thank you so much!!!!

The fact that it is working is giving me soo much hope - no more need for color disasters yipeeeeee x100

Saphire

[gmayor]

I can't test it at the moment, but move the line Set oRng = MyDoc.Range to just below For i = 2 to MyTable.Rows.Count. I think that should do it.

[saphire99]

Dearest Graham,




You did it!!!!!! That solved the problem!

You have saved me from the madness of the case of the disastrous paragraph color shading problem.

Now don't get me wrong I am known to be ditzy vis a vis - applying the wrong color to 50 paragraphs in 30 documents - and what a drama that ensued. Well I have a feeling some one changed the RGB color without telling me -

I was sooo sad - give me < 10 colors and I can just about manage - but 73 RGB colors and counting - it was enough to send me into a space orbit.

Thank you so much for helping me.


After 5 days of coding - I was in a state. I followed at least 20+ plus threads for the table solution.

I really needed help and you came to help me. Also you do help - all the hundreds of others with VBA - where you don't often get credit.


As epic rap battles of history said - you beat me in 17 lines of code. Well any vba pro could beat me in 1 line of VBA - it takes me forever fixing and searching and rearranging that VBA.


I am sending one million kudos points your way.

No more shall the dreaded RGB colors - get their way with me.

Also I will use the other VBA module for the Shaded Font - So that's an added bonus too.

Thank you for helping me at the week end too. As if people like your self don't have anything better to do!

I can start my Monday off setting all those colors.

I have a potent RGB power weapon.

I am the happiest person this side of the time zone.

Thank you so much for being an Amazing VBA Rock star.

And generously trouble shooting as well - absolutely Fabulous.

Yippeeee!

Have an wonderful Sunday

From

Saphire


xoxo


This is happily happily Solved




In the future I will adapt my beloved module - to do other stuff - thank you

[saphire99]

Hello Graham,

and every one again.

As promised I have been able to slightly tweak the code to Replace RGB Text Font Colors as well

This is awesome!

Here is the working Code

Option Explicit

Sub FindReplaceRGBTextColors()

'  Find & Replace RGB Text Colors From a Table - Use a 2 Column Table
'  Graham Mayor


    Dim myDoc As Document
    Dim TableDoc As Document
    Dim myTable As Table
    Dim oRng As Range
    Dim FindColor As Long
    Dim ReplacementColor As Long
    Dim i As Long ' For the table
    Dim myFilename As String
     
     
    'Open this file that has my table of RGB colors and use it to find and replace the Original Font Color
     
    myFilename = "C:\Users\Saphire\Desktop\RGBTextColorsTable.docx"
     
    Set myDoc = ActiveDocument
    
    Set TableDoc = Documents.Open(FileName:=myFilename, Visible:=False)
    Set myTable = TableDoc.Tables(1)
    
    
    For i = 2 To myTable.Rows.Count 'Omit the header row
    Set oRng = myDoc.Range
    
    
        FindColor = myTable.Cell(i, 1).Range.Font.Color          ' Find the Color in Column 1

        ReplacementColor = myTable.Cell(i, 2).Range.Font.Color            ' Replace the Color in Column 2

        With oRng.Find
            .Font.Color = FindColor
            Do While .Execute
                oRng.Select
                oRng.Font.Color = ReplacementColor
            Loop
        End With
    Next i
    TableDoc.Close wdDoNotSaveChanges
lbl_Exit:
    Exit Sub
    

End Sub

Now far be it from me to be overly ambitious with the VBA, but I have discovered I can also add text to it.

To keep my colors in check, I thought I would add on the cell contents in column 2.

The below tweak is to add on the contents found in Column 2 to my font replacement code above.

Set AddColumn2Text = oTable.Cell(i, 2).Range      '  The Text Found in Column 2
     AddColumn2Text.End = AddColumn2Text.End - 1


 Do While .Execute
                oRng.Select
                oRng.Font.Color = ReplacementColor + AddColumn2Text

I know there is a fault there as it is not working. If any one or Graham has any ideas do let me know - I will be so happy to learn how to fix this.

Have a great day

thank you

Saphire

[gmaxey]

You are really making no sense at all. First the working code does not work with the sample files you attached earlier so you are muddying the water for people trying to help you.

Grahams "working" code determined the find and replace colors based on the background shading color applied to the table. Now it appears you are using "font.color" as your reference. "Color" is a long value. Your code can be reduced to this:

Sub FindReplaceRGBTextColors()
Dim oDoc As Document, oColorsDoc As Document
Dim oTbl As Table
Dim oRng As Range
Dim lngIndex As Long
Dim strpath As String
    
  strpath = "D:\Colors.docx" '"C:\Users\Saphire\Desktop\RGBTextColorsTable.docx"
  Set oDoc = ActiveDocument
  Set oColorsDoc = Documents.Open(FileName:=strpath, Visible:=False)
  Set oTbl = oColorsDoc.Tables(1)
  For lngIndex = 2 To oTbl.Rows.Count
    Set oRng = oDoc.Range
    With oRng.Find
      .Font.Color = oTbl.Cell(lngIndex, 1).Range.Font.Color
      While .Execute
        oRng.Font.Color = oTbl.Cell(lngIndex, 2).Range.Font.Color
      Wend
    End With
  Next lngIndex
  oColorsDoc.Close wdDoNotSaveChanges
lbl_Exit:
  Exit Sub
End Sub

Color is a "long" value so you can use oRng.Font.Color = oTbl.Cell(lngIndex, 2).Range.Font.Color + 100 'Some number, but you can't
used oRng.Font.Color = oTbl.Cell(lngIndex, 2).Range.Font.Color + "roses are red" or even "red"

What are you trying to do?

[saphire99]

Hello Greg,

nice to see you again .

Thank you very much for the new and improved upgraded version of the text replace colors.

Yes, you are right my apologies,

It is a cardinal wrong to try and mix numbers and text -the long and the string, the VBA let me know many times, but I'm not sure what to do.

I am so happy for having a table solution to my RGB text problem - I can store all my colors there and replace them all in one go.

Graham's #6 - is working as promised.


I thought it's too good to be true- I have to have a text version to replace the text colors.

For the version you have coded, I simply wanted to add some text - a bit like placeholders before and after the replaced font colors.

I will store the various text in Column 3 & 4

I have been trying to solve this riddle for the past couple of days

I tried the below which did not work.

 With oRng.Find
            .Font.Color = FindColor
            Do While .Execute
            
                oRng.Select

Selection.InsertBefore Column3Text        ' Add some text before the color
Selection.InsertAfter  Column4Text         ' Add some text after the color
oRng.Font.Color = ReplacementColor

I am trying to Achieve maybe something too complicated?

If you do have any ideas do let me know and thank you again.

Thank you for always helping me

Saphire

[gmaxey]

Maybe this:

Sub FindReplaceRGBTextColors()
 Dim oDoc As Document, oColorsDoc As Document
 Dim oTbl As Table
 Dim oRng As Range, oRng2 As Range
 
 Dim lngIndex As Long
 Dim strpath As String
     
    strpath = "D:\Colors.docx" '"C:\Users\Saphire\Desktop\RGBTextColorsTable.docx"
    Set oDoc = ActiveDocument
    Set oColorsDoc = Documents.Open(FileName:=strpath, Visible:=False)
    Set oTbl = oColorsDoc.Tables(1)
    For lngIndex = 2 To oTbl.Rows.Count
        Set oRng = oDoc.Range
        With oRng.Find
            .Font.Color = oTbl.Cell(lngIndex, 1).Range.Font.Color
            While .Execute
              Set oRng2 = oRng.Duplicate
              oRng.Font.Color = oTbl.Cell(lngIndex, 2).Range.Font.Color
              oRng.Collapse wdCollapseEnd
              oRng2.InsertBefore Left(oTbl.Cell(lngIndex, 3).Range.Text, Len(oTbl.Cell(lngIndex, 3).Range.Text) - 2)
              oRng2.InsertAfter Left(oTbl.Cell(lngIndex, 4).Range.Text, Len(oTbl.Cell(lngIndex, 4).Range.Text) - 2)
            Wend
        End With
    Next lngIndex
    oColorsDoc.Close wdDoNotSaveChanges
lbl_Exit:
    Exit Sub
End Sub

[saphire99]

Hello Greg,
What can I say, solved by your skillful mastery as the VBA Guru that you are

How can one compete with the finesse of your code vis a vis below:

oRng2.InsertBefore Left(oTbl.Cell(lngIndex, 3).Range.Text, Len(oTbl.Cell(lngIndex, 3).Range.Text) - 2)

And may I say what an auspicious end to my January.
I was desperately trying to solve this problem, albeit very badly - and then you came to the rescue.


This means so much to me - I am thrilled!

I appreciate the coding help because - I sit at the computer for hours trying to learn the VBA and adapt code - it very rarely works....even when I follow it exactly from the Microsoft website

I appreciate that fine code demands respect !

So may I say - again -

Thank you so much for being soo kind and for being a true generous person.

I hope the forum will commend you for generosity towards newbies like myself who are perpetually vexed and perplexed by the VBA.

What would I do without the help

Thank you again Greg

I hope you will have a great Sunday!

From Saphire

xoxox



** Also Thank you to Graham for helping to put the epic Paragraph Shading problem to rest

** Note to Forum - Please do have a commend or award button - Greg Maxey & Graham Mayor are true STARS

[gmaxey]

Saphire,

What your call finesse is really just a long hand way of eliminating the end of cell mark from a table cell range. In practice you should probably do that with a function. Here you can see at least five possible methods for getting the cell text using a function:

ub DemoMethods()
'This demo requires an active document containing at least one table.
  'Passing the cell object using its row and column index as the argument.
  MsgBox fcnGetCellText1(ActiveDocument.Tables(1).Cell(1, 1))
  MsgBox fcnGetCellText2(ActiveDocument.Tables(1).Cell(1, 1))
  MsgBox fcnGetCellText3(ActiveDocument.Tables(1).Cell(1, 1))
  'Passing a range object as the argument.
  MsgBox fcnGetCellText4(ActiveDocument.Tables(1).Cell(1, 1).Range)
  MsgBox fcnGetCellText5(ActiveDocument.Tables(1).Cell(1, 1).Range)
lbl_Exit:
  Exit Sub
End Sub
Function fcnGetCellText1(ByRef oCell As Word.Cell) As String
  fcnGetCellText1 = Left(oCell.Range.Text, Len(oCell.Range.Text) - 2)
lbl_Exit:
  Exit Function
End Function
Function fcnGetCellText2(ByRef oCell As Word.Cell) As String
Dim oRng As Word.Range
  Set oRng = oCell.Range
  oRng.MoveEnd wdCharacter, -1
  fcnGetCellText2 = oRng.Text
lbl_Exit:
  Exit Function
End Function
Function fcnGetCellText3(ByRef oCell As Word.Cell) As String
  'Replace the end of cell marker with a null string.
  fcnGetCellText3 = Replace(oCell.Range.Text, ChrW(13) & ChrW(7), vbNullString)
lbl_Exit:
  Exit Function
End Function
Function fcnGetCellText4(ByRef oRng As Word.Range) As String
  oRng.End = oRng.End - 1
  fcnGetCellText4 = oRng.Text
lbl_Exit:
  Exit Function
End Function
Function fcnGetCellText5(ByRef oRng As Word.Range) As String
  oRng.Collapse wdCollapseStart
  'Expand the range to the paragraph mark _
  (the first part of the the ChrW(13) & ChrW(7) end of cell mark)
  oRng.Expand
  fcnGetCellText5 = oRng.Text
lbl_Exit:
  Exit Function
End Function

[saphire99]

Dear Greg,

thank you, they will come in handy for my module - and the other tables I have.



Saphire