Just wanted to know if the following code could be simplified without adding an array or a loop.
Variables Cell1, Cell2 & Cell3 are highly independent. That means they won't be the same every time, as they will come from several previous calculations.
With Rng
With .Columns(Cell1).Interior
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With .Columns(Cell2).Interior
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With .Columns(Cell3).Interior
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End With
Is there a way to write something like:
With Rng
With .Columns(Cell1).Interior, .Columns(Cell2).Interior, .Columns(Cell3).Interior
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End With
Thanks,
You could use Union.
With Rng
With Union(.Columns(Cell1), .Columns(Cell2), .Columns(Cell3)).Interior
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End With
Related
I recorded a macro to create a new Pivot Table style so that whenever I create a new worksheet, this Pivot Table Style is added as the default for the Workbook. However, it does not seem to work when I try to run it on a new workbook. At first, I thought it might be the names (i.e. Sheet1), but even when everything matches it errors out on the first line. I hate having to go in and add this new pivot table style to every report I make, so if anyone has any tips, I'd greatly appreciate it. I'm a complete novice at VBA, so if there are any suggestions for making this code shorter, that would be of great help too!
EDIT: The code does not have curly quotations - that was me renaming it for posting.
Additional Edit: This is the error I get:
VBA Error: Run-time error '5': invalid procedure call or arguement
When I hit Debug, it takes me to the first line of code, which is highlighted in yellow: ActiveWorkbook.TableStyles.Add (“Overview”)
Sub Overview_Pivot_Format()
'
' Overview_Pivot_Format Macro
'
'
ActiveWorkbook.TableStyles.Add (“Overview”)
With ActiveWorkbook.TableStyles(“Overview”)
.ShowAsAvailablePivotTableStyle = True
.ShowAsAvailableTableStyle = False
.ShowAsAvailableSlicerStyle = False
.ShowAsAvailableTimelineStyle = False
End With
ActiveWorkbook.DefaultPivotTableStyle = “Overview”
With ActiveWorkbook.TableStyles(“Overview”).TableStyleElements( _
xlWholeTable).Borders(xlEdgeTop)
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
.LineStyle = xlNone
End With
With ActiveWorkbook.TableStyles(“Overview”).TableStyleElements( _
xlWholeTable).Borders(xlEdgeBottom)
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
.LineStyle = xlNone
End With
With ActiveWorkbook.TableStyles(“Overview”).TableStyleElements( _
xlWholeTable).Borders(xlEdgeLeft)
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
.LineStyle = xlNone
End With
With ActiveWorkbook.TableStyles(“Overview”).TableStyleElements( _
xlWholeTable).Borders(xlEdgeRight)
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
.LineStyle = xlNone
End With
With ActiveWorkbook.TableStyles(“Overview”).TableStyleElements( _
xlWholeTable).Borders(xlInsideVertical)
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
.LineStyle = xlNone
End With
With ActiveWorkbook.TableStyles(“Overview”).TableStyleElements( _
xlWholeTable).Borders(xlInsideHorizontal)
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
.LineStyle = xlNone
End With
With ActiveWorkbook.TableStyles(“Overview”).TableStyleElements( _
xlHeaderRow).Interior
.Color = 15658734
.TintAndShade = 0
End With
With ActiveWorkbook.TableStyles(“Overview”).TableStyleElements( _
xlHeaderRow).Borders(xlEdgeTop)
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
.LineStyle = xlNone
End With
With ActiveWorkbook.TableStyles(“Overview”).TableStyleElements( _
xlHeaderRow).Borders(xlEdgeBottom)
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
.LineStyle = xlNone
End With
With ActiveWorkbook.TableStyles(“Overview”).TableStyleElements( _
xlHeaderRow).Borders(xlEdgeLeft)
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
.LineStyle = xlNone
End With
With ActiveWorkbook.TableStyles(“Overview”).TableStyleElements( _
xlHeaderRow).Borders(xlEdgeRight)
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
.LineStyle = xlNone
End With
With ActiveWorkbook.TableStyles(“Overview”).TableStyleElements( _
xlHeaderRow).Borders(xlInsideVertical)
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
.LineStyle = xlNone
End With
With ActiveWorkbook.TableStyles(“Overview”).TableStyleElements( _
xlHeaderRow).Borders(xlInsideHorizontal)
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
.LineStyle = xlNone
End With
With ActiveWorkbook.TableStyles(“Overview”).TableStyleElements( _
xlTotalRow).Font
.FontStyle = "Bold"
.TintAndShade = 0
.ThemeColor = xlThemeColorDark1
End With
With ActiveWorkbook.TableStyles(“Overview”).TableStyleElements( _
xlTotalRow).Interior
.Color = 6697728
.TintAndShade = 0
End With
With ActiveWorkbook.TableStyles(“Overview”).TableStyleElements( _
xlSubtotalRow1).Font
.FontStyle = "Bold"
.TintAndShade = 0
.ThemeColor = xlThemeColorDark1
End With
With ActiveWorkbook.TableStyles(“Overview”).TableStyleElements( _
xlSubtotalRow1).Interior
.Color = 6697728
.TintAndShade = 0
End With
With ActiveWorkbook.TableStyles(“Overview”).TableStyleElements( _
xlSubtotalRow2).Font
.FontStyle = "Bold"
.TintAndShade = 0
.ThemeColor = xlThemeColorDark1
End With
With ActiveWorkbook.TableStyles(“Overview”).TableStyleElements( _
xlSubtotalRow2).Interior
.Color = 6697728
.TintAndShade = 0
End With
With ActiveWorkbook.TableStyles(“Overview”).TableStyleElements( _
xlSubtotalRow3).Font
.FontStyle = "Bold"
.TintAndShade = 0
.ThemeColor = xlThemeColorDark1
End With
With ActiveWorkbook.TableStyles(“Overview”).TableStyleElements( _
xlSubtotalRow3).Interior
.Color = 6697728
.TintAndShade = 0
End With
End Sub
The below worked for me:
Sub Overview_Pivot_Format()
Dim ts As TableStyle, wb As Workbook
Set wb = ActiveWorkbook 'workbook to be updated
On Error Resume Next 'ignore error if no style found in next line
wb.TableStyles("OverView").Delete 'in case already present
On Error GoTo 0 'stop ignoring errors
Set ts = wb.TableStyles.Add("Overview") 'get a reference to the added style
With ts
.ShowAsAvailablePivotTableStyle = True
.ShowAsAvailableTableStyle = False
.ShowAsAvailableSlicerStyle = False
.ShowAsAvailableTimelineStyle = False
End With
wb.DefaultPivotTableStyle = ts
'set properties by calling the 3 subs below...
DoBorders ts.TableStyleElements(xlWholeTable)
DoInterior ts.TableStyleElements(xlHeaderRow), 15658734
DoBorders ts.TableStyleElements(xlHeaderRow)
DoInterior ts.TableStyleElements(xlTotalRow), 6697728
DoFont ts.TableStyleElements(xlTotalRow)
DoInterior ts.TableStyleElements(xlSubtotalRow1), 6697728
DoFont ts.TableStyleElements(xlSubtotalRow1)
DoInterior ts.TableStyleElements(xlSubtotalRow2), 6697728
DoFont ts.TableStyleElements(xlSubtotalRow2)
DoInterior ts.TableStyleElements(xlSubtotalRow3), 6697728
DoFont ts.TableStyleElements(xlSubtotalRow3)
End Sub
'next 3 sub take care of updating the styles...
Sub DoFont(tse As TableStyleElement)
With tse.Font
.FontStyle = "Bold"
.TintAndShade = 0
.ThemeColor = xlThemeColorDark1
End With
End Sub
Sub DoBorders(tse As TableStyleElement)
With tse.Borders() 'no need to set individually...
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
.LineStyle = xlNone
End With
End Sub
Sub DoInterior(tse As TableStyleElement, clr As Long)
With tse.Interior
.Color = clr
.TintAndShade = 0
End With
End Sub
I want the run an IF/ELSE statement across the range of cells selected by the user.
Currently which ever IF/ELSE statement is true for the first cell in the selection, is then applying to all the cells in the section rather than doing a for each loop.
Sub MultiCellTest()
With Selection
If ActiveCell > 10 Then
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 6684927
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Else
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 16764159
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End If
End With
End Sub
Thanks.
Here is how you would modify your code to handle each cell in the active selection.
Sub MultiCellTest()
For Each cell in Selection
If cell > 10 Then
With cell.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 6684927
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Else
With cell.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 16764159
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End If
Next
End Sub
As i wanted to conditional formatting of colour scale in the range as shown below, i recorded the macro while doing it. The code will work but i encountered the "procedure is large error"(compile error) when i do the same thing for 36 pivottables. So is there a way to decrease the size of the procedure so that i can do it for 60 pivotables?
The type of conditional formatting that i used for my colour scale
Sub test()
Range("B5:J12").Select
Selection.FormatConditions.AddColorScale ColorScaleType:=3
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
Selection.FormatConditions(1).ColorScaleCriteria(1).Type = _
xlConditionValueLowestValue
With Selection.FormatConditions(1).ColorScaleCriteria(1).FormatColor
.Color = 7039480
.TintAndShade = 0
End With
Selection.FormatConditions(1).ColorScaleCriteria(2).Type = _
xlConditionValuePercentile
Selection.FormatConditions(1).ColorScaleCriteria(2).Value = 50
With Selection.FormatConditions(1).ColorScaleCriteria(2).FormatColor
.Color = 8711167
.TintAndShade = 0
End With
Selection.FormatConditions(1).ColorScaleCriteria(3).Type = _
xlConditionValueHighestValue
With Selection.FormatConditions(1).ColorScaleCriteria(3).FormatColor
.Color = 8109667
.TintAndShade = 0
End With
Selection.FormatConditions(1).ScopeType = xlSelectionScope
End Sub
Error message
You need to extract the formatting code into a separate sub, and call it from the main code - no need to repeat virtually the same lines over and over.
For example:
Sub Main()
ApplyFC Worksheets("Sheet1").Range("B5:J12")
ApplyFC Worksheets("Sheet2").Range("B5:J12")
'etc etc
End Sub
Sub ApplyFC(rng As Range)
With rng.FormatConditions.AddColorScale(ColorScaleType:=3)
.SetFirstPriority
.ColorScaleCriteria(1).Type = xlConditionValueLowestValue
With .ColorScaleCriteria(1).FormatColor
.Color = 7039480
.TintAndShade = 0
End With
.ColorScaleCriteria(2).Type = xlConditionValuePercentile
.ColorScaleCriteria(2).Value = 50
With .ColorScaleCriteria(2).FormatColor
.Color = 8711167
.TintAndShade = 0
End With
.ColorScaleCriteria(3).Type = xlConditionValueHighestValue
With .ColorScaleCriteria(3).FormatColor
.Color = 8109667
.TintAndShade = 0
End With
.ScopeType = xlSelectionScope
End With
End Sub
I'm trying to make a macro in VBA Excel to apply a few conditional formats.
See below:
Private Sub CommandButton1_Click()
'Delete conditional formats
Sheets("Results").Cells.FormatConditions.Delete
'Red formats
Sheets("Results").Select
With ActiveSheet.Range("C:C,A:A")
.FormatConditions.AddUniqueValues
.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
.FormatConditions(1).DupeUnique = xlDuplicate
End With
With Selection.FormatConditions(1).Font
.Color = -16383844
.TintAndShade = 0
End With
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 13551615
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
'Blue formats
With ActiveSheet.Range("E:E,C:C,A:A")
.FormatConditions.AddUniqueValues
.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
.FormatConditions(1).DupeUnique = xlUnique
End With
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 15773696
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
End Sub
The error pops up in these lines of code:
.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
Sometimes it works sometimes it doesn't.
I recorded this macro and was working fine few days ago.
I was recently given the undertaking of expediting the speed of one of my company's large(ish) macros. I've done quite a decent job so far, as the last writer more or less used the record feature (making some of the code extraneous), which leads me to these formatting conditions:
With Range("AH10:AP10").Interior
.Pattern = xlSolid
.ThemeColor = xlThemeColorDark1
.TintAndShade = -0.249977111117893
End With
With Range("AH17:AP17").Interior
.Pattern = xlSolid
.ThemeColor = xlThemeColorDark1
.TintAndShade = -0.249977111117893
End With
With Range("AH24:AP24").Interior
.Pattern = xlSolid
.ThemeColor = xlThemeColorDark1
.TintAndShade = -0.249977111117893
End With
With Range("AH34:AP34").Interior
.Pattern = xlSolid
.ThemeColor = xlThemeColorDark1
.TintAndShade = -0.249977111117893
End With
With Range("AH42:AP42").Interior
.Pattern = xlSolid
.ThemeColor = xlThemeColorDark1
.TintAndShade = -0.249977111117893
End With
My question then becomes, why does this not work in its place?
Dim RangeArr(5) As Variant
RangeArr(0) = Range("AH10:AP10")
RangeArr(1) = Range("AH17:AP17")
RangeArr(2) = Range("AH24:AP24")
RangeArr(3) = Range("AH34:AP34")
RangeArr(4) = Range("AH42:AP42")
For i = 0 To 4
With RangeArr(i).Interior
.Pattern = xlSolid
.ThemeColor = xlThemeColorDark1
.TintAndShade = -0.249977111117893
End With
Next
I get a run-time error 424, object required for the loop, but using msgbox printing the array is valued as such. I'm assuming it's the array that's written incorrectly, I just can't find out how to fix it. Any suggestions are appreciated. Thanks!
You have made a good start! You need an array of ranges:
Sub human()
Dim RangeArr(0 To 4) As Range
Set RangeArr(0) = Range("AH10:AP10")
Set RangeArr(1) = Range("AH17:AP17")
Set RangeArr(2) = Range("AH24:AP24")
Set RangeArr(3) = Range("AH34:AP34")
Set RangeArr(4) = Range("AH42:AP42")
For I = 0 To 4
With RangeArr(I).Interior
.Pattern = xlSolid
.ThemeColor = xlThemeColorDark1
.TintAndShade = -0.249977111117893
End With
Next
End Sub