Use Word VBA to color cells in tables based on cell value - vba

In Word I have a document with multiple tables full of data. Hidden inside these cells (out of view but the data is there) is the Hex code of the color I want to shade the cells. I chose the hex value just because it's relatively short and it's a unique bit of text that won't be confused with the rest of the text in the cell.
I've found some code online to modify but I can't seem to make it work. It doesn't give any errors, just nothing happens. I feel like the problem is in searching the tables for the text value but I've spent hours on this and I think I've confused myself now!
Sub ColourIn()
Dim oTbl As Table
Dim oCel As Cell
Dim oRng As Range
Dim oClr As String
For Each oTbl In ActiveDocument.Tables
For Each oCel In oTbl.Range.Cells
Set oRng = oCel.Range
oRng.End = oRng.End - 1
If oRng = "CCFFCC" Then
oCel.Shading.BackgroundPatternColor = wdColorLightYellow
End If
If oRng = "FFFF99" Then
oCel.Shading.BackgroundPatternColor = wdColorPaleBlue
End If
Next
Next
End Sub
Thanks!
Edit:
I've also tried this code wit the same result of nothing happening:
Sub EachCellText()
Dim oCell As Word.Cell
Dim strCellString As String
For Each oCell In ActiveDocument.Tables(1).Range.Cells
strCellString = Left(oCell.Range.Text, _
Len(oCell.Range.Text) - 1)
If strCellString = "CCFFFF" Then
oCell.Shading.BackgroundPatternColor = wdColorLightGreen
If strCellString = "CCFFCC" Then
oCell.Shading.BackgroundPatternColor = wdColorLightYellow
If strCellString = "FFFF99" Then
oCell.Shading.BackgroundPatternColor = wdColorPaleBlue
End If
End If
End If
Next
End Sub

Your Code is getting stuck nowhere. But you are checking the whole Cell Value against the Hex code, and this will not work since "blablabla FFFFFF" is never equal to "FFFFFF". So you have to check if the Hex code is in the Cell value:
Sub ColourIn()
Dim oTbl As Table
Dim oCel As Cell
Dim oRng As Range
Dim oClr As String
For Each oTbl In ActiveDocument.Tables
For Each oCel In oTbl.Range.Cells
Set oRng = oCel.Range
oRng.End = oRng.End - 1
Dim cellvalue As String
'check if Colorcode is in cell
If InStr(oRng, "CCFFCC") Then
'Set Cell color
oCel.Shading.BackgroundPatternColor = wdColorLightYellow
'Remove Colorcode from Cell
cellvalue = Replace(oRng, "CCFFCC", "")
'load new value into cell
oRng = cellvalue
End If
Next
Next
End Sub
Now you just have to add all the colors you want to use (I would prefer a Select Case statement) and the code should work fine

Related

Hide full row if cells are merged in word table

I have a file with multiple tables and by using the below code I am trying to access the rows which have specific terms using an array.
I successfully select the whole rows and apply hidden formatting on it but it selects only the first rows of the merged cell, not the whole row.
Below is the result that I am getting.
But I am seeking a result that will hide all content in 4 columns but I am unable to find a solution for the same.
Sub test()
Dim SearchArr() As Variant, Cnt As Integer, Arrcnt As Integer
Dim WrdApp As Object, FileStr As String, WrdDoc As Object, aRng As Range
Dim TblCell As Variant
Set WrdApp = CreateObject("Word.Application")
WrdApp.Visible = True
'********** change address to suit
FileStr = "C:\Users\krishna.haldunde\Downloads\New folder\Episode_0_intro_UEFA_v1_EN.docx"
Set WrdDoc = WrdApp.Documents.Open(FileStr)
SearchArr = Array("Slide Notes")
'loop tables
For Cnt = 1 To WrdApp.ActiveDocument.Tables.Count
'loop search word
For Arrcnt = LBound(SearchArr) To UBound(SearchArr)
'loop through table cells
For Each TblCell In WrdApp.ActiveDocument.Tables(Cnt).Range.Cells
Set aRng = TblCell.Range
'If TblCell.RowIndex = WrdApp.ActiveDocument.Tables(Cnt).Rows.Count Then Exit For
If InStr(LCase(aRng), LCase(SearchArr(Arrcnt))) Then
aRng.Rows.Select
WrdApp.Selection.Font.Hidden = True
WrdApp.Selection.Range.HighlightColorIndex = wdBlue
'WrdApp.Selection.Range.Next.Rows.Select
'WrdApp.Selection.Font.Hidden = True
'WrdApp.Selection.Range.HighlightColorIndex = wdBlue
End If
Next TblCell
Next Arrcnt
Next Cnt
End Sub
Can anyone help me out to understand where I am doing the issue so, I can rectify it?

Apply the Hidden behavior on the whole row

I have a file with multiple tables and by using the below code I am trying to access the rows which have specific terms using an array.
I successfully select the whole rows but when I try to apply the Hidden behavior on the whole row then VBA through an error.
Getting error on below the line
Selection.Font.Hidden = True
Below is my whole code
Sub test()
Dim SearchArr() As Variant, Cnt As Integer, Arrcnt As Integer
Dim WrdApp As Object, FileStr As String, WrdDoc As Object, aRng As Range
Dim TblCell As Variant
Set WrdApp = CreateObject("Word.Application")
WrdApp.Visible = True
'********** change address to suit
FileStr = "C:\Users\krishna.haldunde\Downloads\DE\DE\International_DE.docx"
Set WrdDoc = WrdApp.Documents.Open(FileStr)
SearchArr = Array("French", "Spanish")
'loop tables
For Cnt = 1 To WrdApp.ActiveDocument.Tables.Count
'loop search word
For Arrcnt = LBound(SearchArr) To UBound(SearchArr)
'loop through table cells
For Each TblCell In WrdApp.ActiveDocument.Tables(Cnt).Range.Cells
Set aRng = TblCell.Range
'If TblCell.RowIndex = WrdApp.ActiveDocument.Tables(Cnt).Rows.Count Then Exit For
If InStr(LCase(aRng), LCase(SearchArr(Arrcnt))) Then
aRng.Select
Selection.Font.Hidden = True
End If
Next TblCell
Next Arrcnt
Next Cnt
End Sub
Can anyone help me out to understand where i am doing issue so, i can rectify it.
I think it's more effective to reduce the row height to an exact minimum value.
Something like this works for me.
Sub Test()
SearchArr = Array("sdg", "sdh", "dsf")
'loop tables
For Cnt = 1 To ActiveDocument.Tables.Count
'loop search word
For Arrcnt = LBound(SearchArr) To UBound(SearchArr)
'loop through table cells
For Each tblCell In ActiveDocument.Tables(Cnt).Range.Cells
Set aRng = tblCell.Range
If InStr(LCase(aRng), LCase(SearchArr(Arrcnt))) Then
ActiveDocument.Tables(Cnt).Rows(tblCell.RowIndex).HeightRule = wdRowHeightExactly
ActiveDocument.Tables(Cnt).Rows(tblCell.RowIndex).Height = 1
End If
Next tblCell
Next Arrcnt
Next Cnt
End Sub

Set the color of a table cell depending on the content

I'm trying to write a VBA code in MS Word 2016 in order to fill cells containing a certain string ("–" in my case). I have tried something like this:
Sub CellsColorFill()
Dim tTable As Table
Dim cCell As Cell
For Each tTable In ActiveDocument.Range.Tables
For Each cCell In tTable.Range.Cells
If cCell.Range = "-" Then
Selection.Shading.Texture = wdTextureNone
Selection.Shading.ForegroundPatternColor = wdColorAutomatic
Selection.Shading.BackgroundPatternColor = -603923969
End If
Next
Next
Set oCell = Nothing
Set tTable = Nothing
End Sub
However, for some reason, it has no effect when executed. How could this task be done?
Note - It is good to have Option Explicit at the top of the module to help you point out undeclared variable. oCell is not declared and I assume it's a typo of cCell
To check if a string contains a certain string, you can use InStr to check if returns a non-0 value (0 means not found)
Option Explicit
Sub CellsColorFill()
Dim tTable As Table
Dim cCell As Cell
For Each tTable In ActiveDocument.Range.Tables
For Each cCell In tTable.Range.Cells
If InStr(cCell.Range.Text, "-") <> 0 Then
cCell.Shading.Texture = wdTextureNone
cCell.Shading.ForegroundPatternColor = wdColorAutomatic
cCell.Shading.BackgroundPatternColor = -603923969
End If
Next
Next
End Sub

Script for fixing broken hyperlinks in Excel

I have a spreadsheet that is used for tracking work orders. The first column of the sheet has numbers starting at 14-0001 and continue sequentially all the way down. The numbers were hyperlinked to the .XLS of their respective work order (ex. the cell containing 14-0001 links to Z:\WorkOrders\14-0001-Task Name\14-0001-Task Name.xls)
Problem is, My computer crashed and when Excel recovered the file all the hyperlinks changed from:
**"Z:\blah blah\WorkOrders\14-****-Task Name\14-****-Task Name.xls"**
to
**"C:\Users\blahblah\WorkOrders\14-****-Task Name\14-****-Task Name.xls"**
There are hundreds of entries so I was hoping that I could run a script to fix all of the hyperlinks.
Heres a script I found online which from what I understood is supposed to do what I want, but when I run the script from the VB window in Excel I get "Compile error: Argument not optional" and it highlights Sub CandCHyperlinx()
Code:
Option Explicit
Sub CandCHyperlinx()
Dim cel As Range
Dim rng As Range
Dim adr As String
Dim delstring As String
'string to delete: CHANGE ME! (KEEP quotes!)
delstring = "C:\Users\***\AppData\Roaming\Microsoft\Excel\"
'get all cells as range
Set rng = ActiveSheet.UsedRange
'ignore non hyperlinked cells
On Error Resume Next
'check every cell
For Each cel In rng
'skip blank cells
If cel <> "" Then
'attempt to get hyperlink address
adr = cel.Hyperlinks(1).Address
'not blank? then correct it, is blank get next
If adr <> "" Then
'delete string from address
adr = Application.WorksheetFunction.Substitute(adr, delstring)
'put new address
cel.Hyperlinks(1).Address = adr
'reset for next pass
adr = ""
End If
End If
Next cel
End Sub
Is this even the right script? What am I doing wrong?
Try this:
Sub Macro1()
Const FIND_TXT As String = "C:\" 'etc
Const NEW_TXT As String = "Z:\" 'etc
Dim rng As Range, hl As Hyperlink
For Each rng In ActiveSheet.UsedRange.Cells
If rng.Hyperlinks.Count > 0 Then
Set hl = rng.Hyperlinks(1)
Debug.Print rng.Address(), "Before", hl.TextToDisplay, hl.Address
hl.TextToDisplay = Replace(hl.TextToDisplay, FIND_TXT, NEW_TXT)
hl.Address = Replace(hl.Address, FIND_TXT, NEW_TXT)
Debug.Print rng.Address(), "After", hl.TextToDisplay, hl.Address
End If
Next rng
End Sub
I've just had the same problem, and all the macros I tried didn't work for me. This one is adapted from Tim's above and from this thread Office Techcentre thread. In my case, all my hyperlinks were in column B, between rows 3 and 400 and 'hidden' behind the filename, and I wanted to put the links back to my Dropbox folder where they belong.
Sub FixLinks3()
Dim intStart As Integer
Dim intEnd As Integer
Dim strCol As String
Dim hLink As Hyperlink
intStart = 2
intEnd = 400
strCol = "B"
For i = intStart To intEnd
For Each hLink In ActiveSheet.Hyperlinks
hLink.TextToDisplay = Replace (hLink.TextToDisplay, "AppData/Roaming/Microsoft/Excel",
"Dropbox/References")
hLink.Address = Replace(hLink.Address, "AppData/Roaming/Microsoft/Excel",
"Dropbox/References")
Next hLink
Next i
End Sub
Thanks for your help, Tim!

Cannot use named range when it is empty

I have a named range lstVendors that refers to: =OFFSET(Data!$W$2,0,0,COUNTA(Data!$W$2:$W$400),1). I want this range to be populated when the workbook opens. I have the following code for this:
Private Sub Workbook_Open()
Application.WindowState = xlMaximized
Dim rslt()
Dim i As Integer
Dim n As Integer
Dim startRng As Range
Dim DropDown1 As DropDown
ThisWorkbook.Sheets("Dashboard").Shapes("TextBox 6").Visible = False
' Range("lstVendors").Offset(0, 0).Value = "Please Select..."
' Set DropDown1 = ThisWorkbook.Sheets("Dashboard").DropDowns("Drop Down 1")
' DropDown1.Value = 1
On Error Resume Next
If Not IsError(Range("lstVendors")) Then
Range("lstVendors").ClearContents
End If
On Error GoTo 0
rslt = Application.Run("SQLite_Query", "path/to/my/sqlite", "SELECT PROGRAM_ID FROM VENDOR;")
Set startRng = Range("lstVendors")
i = 0
For n = 2 To UBound(rslt)
Range("lstVendors").Offset(i, 0).Value = rslt(n)(0)
i = i + 1
Next n
End Sub
It errors on the Set startRng = Range("lstVendors"). I know this is because there's nothing in the range when I'm trying to set it, because if I put one entry into the named range, the set works, however, I need it populated by the sqlite query on each open as the data changes.
Any suggestions much appreciated.
Try this. You have a dynamic range that doesn't evaluate after you clear the contents. To avoid this, there are probably several ways, but easy to simply hardcode the startRange variable so that it always points to Data!$W$2 address, which is (or rather, will become) the first cell in your lstVendors range.
Private Sub Workbook_Open()
Dim rslt()
Dim i As Integer
Dim n As Integer
Dim startRng As Range
Dim DropDown1 As DropDown
Dim rngList As Range
'// Define your startRange -- always will be the first cell in your named range "lstVendors"
' hardcode the address because the dynamic range may not evalaute.
Set startRange = Sheets("Data").Range("W2")
'// Empty th lstVendors range if it exists/filled
On Error Resume Next
Range("lstVendors").Clear
On Error GoTo 0
'// Run your SQL query
rslt = Application.Run("SQLite_Query", "path/to/my/sqlite", "SELECT PROGRAM_ID FROM VENDOR;")
i = 0
'// Print results to the Worksheet, beginning in the startRange cell
For n = 2 To UBound(rslt)
'Increment from the startRange cell
startRange.Offset(i, 0).Value = rslt(n)(0)
i = i + 1
'Verify that "lstVendors" is being populated
Debug.Print Range("lstVendors").Address
Next n
End Sub
Thanks for the suggestions. Here is what I ended up doing in order to get around my problem. It involves adding something I didn't specify would be ok in my original question, so David's answer is great if what I did isn't an option. I first populated the first two cells in my named range with "Please Select..." and "All". In Sub Workbook_Open() we do this:
Private Sub Workbook_Open()
Application.WindowState = xlMaximized
Dim rslt()
Dim i As Integer
Dim n As Integer
Dim startRng As Range
Dim DropDown1 As DropDown
' Disable our not found message
ThisWorkbook.Sheets("Dashboard").Shapes("TextBox 6").Visible = False
' Set our start range to our named range
Set startRng = Range("lstVendors")
' Grab all vendor names
rslt = Application.Run("SQLite_Query", "path/to/my/sqlite", "SELECT PROGRAM_ID FROM VENDOR;")
' Print result. Skip first two rows as constants "Please Select..." and "All" are populated there
i = 2
For n = 2 To UBound(rslt)
startRng.Offset(i, 0).Value = rslt(n)(0)
i = i + 1
Next n
End Sub
Then we will create Sub Workbook_BeforeClose:
Private Sub Workbook_BeforeClose(Cancel As Boolean)
' Disable the save changes dialog. This workbook will be locked up for display only. No need to confuse the user.
Application.DisplayAlerts = False
' Clear everything below the "Please Select..." and "All" cells in the named range
On Error Resume Next
Range("lstVendors").Offset(2, 0).ClearContents
On Error GoTo 0
' Save the changes to the named range
ThisWorkbook.Save
Application.DisplayAlerts = True
End Sub
This information is going to populate a drop down, so having Please Select and All hardcoded into the named range is acceptable for me. If that stipulation doesn't work for someone else looking at this in the future, please use David's suggestion! Thanks again!