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

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

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?

15248


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



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/30028212/word-vba-for-search-replace-tables and also many others - that had something to do with a table, as you can imagine it can be very confusing :stars:



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

[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

15250


Table in

UpdateParagraphColors.docx

15251


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

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.


15252


15253

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

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


15259

15261


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,

:bow:


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

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

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 - :omg2: and what a drama that ensued. Well I have a feeling some one changed the RGB color without telling me - :devil2:

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

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

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

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

And generously trouble shooting as well - absolutely Fabulous.

Yippeeee!

Have an wonderful Sunday

From

Saphire


xoxo


This is happily happily Solved

:wavey:


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

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

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

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

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

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. :sparkle:
I was desperately trying to solve this problem, albeit very badly - and then you came to the rescue. :knight:


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

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

Thank you again Greg

I hope you will have a great Sunday! :biggrin:

From Saphire

xoxox

:wavey:

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

[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.

:biggrin:

Saphire