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
Related
VBA
Excel 2016
I'm trying to dynamically resize a range if the number of columns is less for that range after some code is executed. Referenced the MS files and various online examples with no luck. https://msdn.microsoft.com/en-us/library/office/ff193274.aspx
I can achieve the correct resize only if I do something like "testRange.Resize Range("A1:G1"). However I am looking for something along the lines of:
Sub Test_Range()
Dim Test As Worksheet
Set Test = Worksheets("test")
Dim testTable As Range
Set testTable = Test.Range("testTable[]")
Dim testTableWidth, testNumbersWidth As Integer
Set testTableWidth = testTable.Columns.Count
'Some code
'testNumbersWith is defined here
If testNumbersWidth < testTableWidth Then
testTable.Resize(, testNumbersWidth)
End If
End Sub
The method to resize a "Named Range" is different if it is a "normal" named range or a "Table" (ListObject) range. Your title refers to the first case but from your code it seems you are working with a table.
For the case of a named range, you change the scope like this (i.e. to change the number of columns):
With ThisWorkbook.Names.Item("testTable")
.RefersTo = .RefersToRange.Resize(, newColumnsCount)
End With
For the case of a Table (ListObject), which seems to be your case, you can change the number of columns like this:
Dim testTable As ListObject ' <-- Declare as ListObject
Set testTable = Test.ListObjects("testTable")
' Or Set testTable = Test.Range("testTable")
'Some code
' ....
testTable.Resize testTable.Range.Resize(, newColumnsCount) ' <-- resize number of cols
Assuming your other code .ClearContents on some columns in the Table (ListObject), say originally you have this:
Then lets say some code clears the content of columns D and I (headers C and H):
Running the code below will remove those columns from Table (by deleting the entire column). You can then use the list table's .DataBodyRange to access the table data only.
Option Explicit
Sub TableResize()
Dim oTable As ListObject, oRng As Range, sColsToDelete As String
Set oTable = ActiveSheet.ListObjects("Table1")
For Each oRng In oTable.HeaderRowRange
Debug.Print oRng.Address(0, 0), oRng.Value
If oRng.Value Like "Column*" Then
Debug.Print "Column " & oRng.Column & " to be deleted"
' Note order to delete is reversed!
If Len(sColsToDelete) > 0 Then sColsToDelete = "," & sColsToDelete
sColsToDelete = oRng.Column & sColsToDelete
End If
Next
If Len(sColsToDelete) > 0 Then DeleteCol sColsToDelete
' Example to access the data ranges
For Each oRng In oTable.DataBodyRange
Debug.Print oRng.Address(0, 0), oRng.Value
Next
Set oTable = Nothing
End Sub
Private Sub DeleteCol(sList As String)
Dim oItem As Variant
For Each oItem In Split(sList, ",")
ActiveSheet.Columns(CLng(oItem)).Delete
Next
End Sub
The result of the TableResize execution:
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
I am creating macro which will loop through column F and will delete month april from 2013. It seem that the macro is deleting all :-D. I dont know how to set it to delete only my criteria I tried (Month(Now) - 2). Mine date of format looks like DD/MM/YYYY.
Thank you for your help.
Sub Test1()
Dim rgFoundCell As Range
Dim toBeDeted As Range
Dim firstAddress
With Sheets("Sheet1").Range("F:F")
Set rgFoundCell = .Find(What:=(Month(Now) - 2))
If Not rgFoundCell Is Nothing Then
firstAddress = rgFoundCell.Address
Do
If toBeDeted Is Nothing Then
Set toBeDeted = rgFoundCell.EntireRow
Else
Set toBeDeted = Union(toBeDeted, rgFoundCell.EntireRow)
End If
Set rgFoundCell = .FindNext(rgFoundCell)
If rgFoundCell Is Nothing Then Exit Do
Loop While rgFoundCell.Address <> firstAddress
End If
End With
Application.ScreenUpdating = True
If Not toBeDeted Is Nothing Then _
toBeDeted.Delete ' Delete
End Sub
You can't use .Find in the way you think - it is only able to do text match or number match comparisons. This leaves you with having to cycle through each cell in the range and run your comparison explicitly on each cell
Sub Test1()
Dim toBeDeleted As Range
With Sheets("Sheet1").Range("F:F")
For Each c In .Cells
If Month(c.Value) = 3 And Year(c.Value) = 2013 Then
If toBeDeleted Is Nothing Then
Set toBeDeleted = c.EntireRow
Else
Set toBeDeleted = Union(toBeDeleted, c.EntireRow)
End If
End If
Next
End With
If Not toBeDeleted Is Nothing Then _
toBeDeleted.Delete ' Delete
End Sub
You might want to consider running the function on a more refined range than the full F column or use an end of data marker like checking for a blank row to stop the loop.
Try this:
Sub Test1()
On Error GoTo e
Application.ScreenUpdating = False
Dim rng As Range
Dim firstAddress
Set rng = Sheets("Sheet1").Range("F1", Sheets("Sheet1").Range("F1").End(xlDown))
Dim i As Long
i = 1
While i <= rng.Count
If Month(CDate(rng(i))) = 4 And Year(CDate(rng(i))) = 2014 Then
rng (i).EntireRow.Delete
Else
i = i + 1
End If
Wend
x:
Application.ScreenUpdating = True
Exit Sub
e:
MsgBox (Err.Description)
Resume x
End Sub
Maybe try to reduce the F:F range!!!
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!
Trying to loop through a range of cells and assigned a label to them based off of the text value in another cell. So if Cell J2 = "This Text" Then Cell A2 = "This Label"
As of now I keep getting a run time error number 424, stating object required
Private Function getPhase(ByVal cell As Range) As String
Select Case cell.Text
Case "Text1"
getPhase = "Label1"
Case "Text2"
getPhase = "Label2"
End Select
End Function
Sub setPhase()
Dim cycle As Range
Dim phase As Range
Set cycle = Range("J2:J10")
Set phase = Range("A2:A10")
For Each cell In phase.Cells
phase.Text = getPhase(cycle)
Next cell
End Sub
You have already got your answers :) Let me do some explaining in my post though :)
You cannot use this.
phase.Text = getPhase(cycle)
.Text is a Readonly property. i.e you cannot write to it but only read from it. You have to use .Value
Secondly you don't need to define the 2nd range if you are picking values from the same row. You can always us the .Offset property. See this
Option Explicit
Sub setPhase()
Dim rng As Range, phase As Range
Set phase = Sheets("Sheet1").Range("A2:A10")
For Each rng In phase
rng.Value = getPhase(rng.Offset(, 9))
Next
End Sub
Function getPhase(ByVal cl As Range) As String
Select Case cl.Value
Case "Text1"
getPhase = "Label1"
Case "Text2"
getPhase = "Label2"
End Select
End Function
Also there is nothing wrong with Select Case cell.Text since you are only reading from it. However, it is always good to use .Value. Reason being the .Value property returns the actual value of the cell where as .Text property returns the text which is displayed on the screen. The limit of Text is approx 8k characters in higher versions of Excel. The .Value on the other hand can store up to 32k characters.
I've changed the loop. This assumes that the two ranges are the same lengths
Function getPhase(ByVal cell As Range) As String
Select Case cell.Value
Case "Text1"
getPhase = "Label1"
Case "Text2"
getPhase = "Label2"
End Select
End Function
Sub setPhase()
Dim cycle As Range
Dim phase As Range
Set cycle = ThisWorkbook.Sheets("myexample").Range("J2:J10")
Set phase = ThisWorkbook.Sheets("myexample").Range("A2:A10")
Dim i As Integer
For i = 1 To phase.Cells.Count
phase.Cells(i).Value = getPhase(cycle.Cells(i))
Next i
End Sub
...or as siddharth had suggested use a formula.
Or do the formula via VBA:
Sub setPhase()
Dim phase As Range
Set phase = Excel.ThisWorkbook.Sheets("Sheet1").Range("A2:A10")
phase.Value = "=IF(J2=""Text1"",""Label1"",IF(J2=""Text2"",""Label2"",""""))"
End Sub
Here is my version:
Private Function getPhase(ByVal cell As Range) As String
Select Case cell.Text
Case "Text1"
getPhase = "Label1"
Case "Text2"
getPhase = "Label2"
End Select
End Function
Sub setPhase()
Dim cycle As Range
Dim phase As Range
Set cycle = ActiveSheet.Range("b2:b10")
Set phase = ActiveSheet.Range("A2:A10")
For Each cell In phase.Cells
cell.Value = getPhase(cycle.Cells(cell.Row, 1))
Next cell
End Sub