Highlight only a few columns and cells within a row - vba

How could I edit my code to only highlight the row from column G:K instead of wasting memory and time highlighting the entire row?
With ActiveSheet 'set this worksheet properly!
'lastrow = .cells(Rows.Count, 1).End(xlUp).Row
lastrow = Range("K6500").End(xlUp).Row - 2
For Each cell In .Range("K3:K" & lastrow)
If cell = "Wrong Date" Then
'With cell.EntireRow.Interior
With cell.Range("G:K").Value.Interior.ColorIndex = 3
Rows().Select
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 3937500
.TintAndShade = 0
.PatternTintAndShade = 0
End With
My current code does not work as I've tried replacing With cell.EntireRow.Interior with With cell.Range("G:K").Value.Interior.ColorIndex = 3
Excuse me this is what I mean I am trying to do
Sub highlight_wrong_Date()
Dim Rng As Range, lCount As Long, lastrow As Long
Dim cell As Object
With ActiveSheet 'set this worksheet properly!
lastrow = Range("K6500").End(xlUp).Row - 2
For Each cell In .Range("K3:K" & lastrow)
If cell = "Wrong Date" Then
With cell.Range(.cells(cell.Row, "G"), .cells(cell.Row, "K"))
Rows().Select
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 3937500
.TintAndShade = 0
.PatternTintAndShade = 0
End With
ElseIf cell = "Pass" Then
With cell.Range(.cells(cell.Row, "G"), .cells(cell.Row, "K"))
Rows().Select
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 61046
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Else
With cell.EntireRow.Interior
Rows().Select
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End If
Next cell
End With
End Sub
But I receive an error saying the cell object does not support this. If a cell has either a value of "Wrong Date" or "Pass" within column O I want to highlight red or green respectively.
3rd Edit
Sub highlight_wrong_Date()
Dim Rng As Range, lCount As Long, lastrow As Long
Dim cell_value As Object
With ActiveSheet 'set this worksheet properly!
lastrow = Range("K6500").End(xlUp).Row - 2
For Each cell_value In .Range("K3:K" & lastrow)
If cell_value = "Wrong Date" Then
With .Range(.cells(cell.Row, "G"), .cells(cell.Row, "K"))
'Rows().Select
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 3937500
.TintAndShade = 0
.PatternTintAndShade = 0
End With
ElseIf cell_value = "Pass" Then
With .Range(.cells(cell.Row, "G"), .cells(cell.Row, "K"))
'Rows().Select
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 61046
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Else
With cell.EntireRow.Interior
Rows().Select
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End If
Next cell_value
End With
End Sub

Your references should be
With .Range("G" & cell.Row & ":K" & cell.Row)

Related

object out of range error for no reason

I am writing the code below in VBA macro excel, my problem is that I get the object our of range error in the line (107, col 10) and I don't know why.
the line I get the error
.Range(.Cells(x, "A"), .Cells(x, "AC")).Select
my code is below
Sub MRP()
'
' Macro1 Macro
'
'
Dim wks As Worksheet
Dim OPwks As Worksheet
Dim MRPwks As Worksheet
Dim OPDwks As Worksheet
Dim DbCwks As Worksheet
Dim x As Long
Dim p As Integer, i As Long, q As Long
Dim a As Integer, m As Integer, k As Long
Dim rowRange As Range
Dim colRange As Range
Dim LastCol As Long
Dim LastRowOPwks As Long
Dim LastRowMRPwks As Long
Dim LastRowDBCwks As Long
Set MRPwks = Worksheets("MRP")
Set OPwks = Worksheets("OpenPOsReport")
Set DbCwks = Worksheets("CompDB")
Set wks = ActiveSheet
Worksheets("OpenPOsReport").Activate
LastRowMRPwks = MRPwks.Cells(MRPwks.Rows.Count, "A").End(xlUp).Row
LastRowOPwks = OPwks.Cells(OPwks.Rows.Count, "A").End(xlUp).Row
LastRowDBCwks = DbCwks.Cells(DbCwks.Rows.Count, "A").End(xlUp).Row
'Set rowRange = wks.Range("A1:A" & LastRow)
'For m = 8 To LastRow
'Cells(m, "N") = 0
'Next m
For i = 2 To LastRowDBCwks
p = 0
For q = 8 To LastRowOPwks
If DbCwks.Cells(i, "V") = 0 Then k = 0 Else: k = p / Cells(i, "V")
If OPwks.Cells(q, "A") = DbCwks.Cells(i, "A") Then
If OPwks.Cells(q, "D") = 0 Or OPwks.Cells(q, "B") < 1 / 1 / 18
Then GoTo Nextiteration Else
If (OPwks.Cells(q, "C") + DbCwks.Cells(i, "C")) >=
(DbCwks.Cells(i, "F") + k) Then
OPwks.Cells(q, "N").Value = 1
OPwks.Range(Cells(q, "A"), Cells(q, "N")).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 255
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Else
p = p + OPwks.Cells(q, "D").Value
OPwks.Cells(q, "N").Value = 0
OPwks.Range(Cells(q, "A"), Cells(q, "O")).Select
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End If
End If
Nextiteration:
Next q
Next i
'For q = 8 To LastRow
' If Cells(q, "N") = 1 Then
' End If
' Next
With MRPwks
For x = 5 To LastRowMRPwks
If .Cells(x, "AC").Value > 0 Then
.Range(.Cells(x, "A"), .Cells(x, "AC")).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 255
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End If
If .Cells(x, "AC") = 0 Then
.Range(.Cells(x, "A"), .Cells(x, "AC")).Select
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End If
Next x
End With
End Sub
I dont know why I get the Object out of range error in the first part of the code.
You have Worksheets("OpenPOsReport").Activate in your code, then you try to select .Range(.Cells(x, "A"), .Cells(x, "AC")).Select on MRPwks which is not active at that time. This is not possible.
Change your code to
With MRPwks
For x = 5 To LastRowMRPwks
If .Cells(x, "AC").Value > 0 Then
With .Range(.Cells(x, "A"), .Cells(x, "AC")).Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 255
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End If
If .Cells(x, "AC") = 0 Then
With .Range(.Cells(x, "A"), .Cells(x, "AC")).Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End If
Next x
End With
It is not neccessary to select the range first.
You can avoid this error if you don't try to Select the range (because you cannot select a range on a sheet that's inactive). One common mistake is to say "OK, well, then I'll just add a .Activate to make sure the right sheet is active. But that leads to spaghetti code, as you constantly need to keep track of which sheet in which workbook is active, makes the code hard to read and harder to debug.
Selecting/Activating things in Excel is almost never necessary, and when you do it this way it tends to cause all sorts of difficult-to-troubleshoot errors, like the one you have.
Dim rngToFormat as Range
For x = 5 To LastRowMRPwks
Set rngToFormat = .Cells(x, "A").Resize(1,29)
If rngToFormat.Cells(29).Value > 0 Then
With rngToFormat.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 255
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Else
With rngToFormat.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End If
Next x

Cells Format and subtotals with VBA

I have created a VBA macro to give the format to Sheet in excel and create some subtotals.
It works, but has a lot of room for improvement.
Right now it takes very long.
I know that using Matrix the processing time could be reduced to milliseconds.
Sub justsubttotals()
Sheets("Produktionsplan").Select
'Delete previous format
Range("A4:I1000").Select
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlHairline
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
'I define 3 start variables with the first row of the matrix (per default it always starts in row 4).
primero = 4
fin = 4
contar = 4
'Identify how many rows are in the file
Finalrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
For j = 4 To Finalrow
If Cells(j, 1) = 0 And contar <= Finalrow Then
Cells(j, 1).Select
Selection.EntireRow.Select
Selection.Delete Shift:=xlUp
j = j - 1
contar = contar + 1
Else
contar = contar + 1
End If
Next
inicio = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
'Este inicio lo guardo para la parte de los subtotales
inicio2 = inicio
'Este inicio si es para los formatos
inicio = inicio + 1
For i = 4 To inicio
For j = primero To inicio
If Cells(primero, 4) = Cells(fin + 1, 4) Then
fin = fin + 1
Else
j = inicio
End If
Next
'Based on the description of column 2, I know which colour to assign
If Cells(primero, 2) = "B. Rück RH" Or Cells(primero, 2) = "B. 7 OB RH" Then
Range("A" & primero & ":I" & fin).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent6
.TintAndShade = 0.699981688894314
.PatternTintAndShade = 0
End With
ElseIf Cells(primero, 2) = "B. Rück LH" Or Cells(primero, 2) = "B. 7 OB LH" Then
Range("A" & primero & ":I" & fin).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent6
.TintAndShade = 0.499981688894314
.PatternTintAndShade = 0
End With
ElseIf Cells(primero, 2) = "B. 7 SAMS Center " Then
Range("A" & primero & ":I" & fin).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 8771461
.TintAndShade = 0
.PatternTintAndShade = 0
End With
ElseIf Cells(primero, 2) = "B. 7 SAMS LH " Then
Range("A" & primero & ":I" & fin).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 8771461
.TintAndShade = 0
.PatternTintAndShade = 0
End With
ElseIf Cells(primero, 2) = "B. 7 SAMS RH " Then
Range("A" & primero & ":I" & fin).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 8771461
.TintAndShade = 0
.PatternTintAndShade = 0
End With
ElseIf Cells(primero, 2) = "B. 634 RH/LH " Then
Range("A" & primero & ":I" & fin).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 6723891
.TintAndShade = 0
.PatternTintAndShade = 0
End With
ElseIf Cells(primero, 2) = "B. Vor RH" Then
Range("A" & primero & ":I" & fin).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent5
.TintAndShade = 0.699981688894314
.PatternTintAndShade = 0
End With
ElseIf Cells(primero, 2) = "B. Vor LH" Then
Range("A" & primero & ":I" & fin).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent2
.TintAndShade = 0.699981688894314
.PatternTintAndShade = 0
End With
ElseIf Cells(primero, 2) = "Porsche RH" Then
Range("A" & primero & ":I" & fin).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent5
.TintAndShade = 0.399975585192419
.PatternTintAndShade = 0
End With
ElseIf Cells(primero, 2) = "Porsche LH" Then
Range("A" & primero & ":I" & fin).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent2
.TintAndShade = 0.399993896298105
.PatternTintAndShade = 0
End With
ElseIf Cells(primero, 2) = "Audi RH" Then
Range("A" & primero & ":I" & fin).Select
With Selection.Interior
.Pattern = xlSolid
.ThemeColor = xlThemeColorDark2
.TintAndShade = -9.99786370433668E-02
.TintAndShade = 0.699981688894314
.PatternTintAndShade = 0
End With
ElseIf Cells(primero, 2) = "Audi LH" Then
Range("A" & primero & ":I" & fin).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent3
.TintAndShade = 0.599993896298105
.PatternTintAndShade = 0
End With
Else
Range("A" & primero & ":I" & fin).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End If
Range("A" & primero & ":I" & fin).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlHairline
End With
primero = fin + 1
Next
'************************************************
'I create the subtotals
'************************************************
primero = 4
fin = 4
inicio = inicio2
For i = 4 To inicio
For j = primero To inicio
If Cells(primero, 4) = Cells(fin + 1, 4) Then
fin = fin + 1
Else
j = inicio
End If
Next
If fin > primero Then
Rows(fin + 1 & ":" & fin + 1).Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
inicio = inicio + 1
Range("H" & fin + 1).Select
Cells(fin + 1, 8).Value = "=Sum(H" & primero & ":H" & fin & ")"
Range("H" & fin + 1).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Selection.Font.Bold = True
Else
Range("H" & fin).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Selection.Font.Bold = True
End If
primero = fin + 1
Next
'************************************************
'I use the formula of another sheet
'************************************************
Sheets("RuestenMatrix").Select
Range("J1").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Produktionsplan").Select
Range("J4:J810").Select
ActiveSheet.Paste
'************************************************
'Once again I use the formula of another sheet
'************************************************
Sheets("Pause Zeit").Select
Range("K4:K5").Select
Selection.Copy
Sheets("Produktionsplan").Select
Range("K4").Select
ActiveSheet.Paste
Range("K5").Select
Application.CutCopyMode = False
Selection.AutoFill Destination:=Range("K5:K810")
Range("K5:K810").Select
'************************************************
'One more time I use the formula of another sheet
'************************************************
Cells(4, 13).Select
Sheets("Pause Zeit").Select
Range("M4:P5").Select
Selection.Copy
Sheets("Produktionsplan").Select
ActiveSheet.Paste
Range("M5:P5").Select
Application.CutCopyMode = False
Selection.AutoFill Destination:=Range("M5:P872")
Range("M5:P872").Select
Range("M4").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Selection.Font.Bold = True
End Sub

Code not cycling through sheets

My Workbook has several sheets named Detail1, Detail2, Detail3, and so on. I´d like to color the sheet according to the content of cell B15. However the code is only coloring sheet Detail1 and not cycling through the other sheets. What am I doing wrong?
Sub Color_by_cell_value()
Dim X As String
Dim ws As Worksheet
For Each ws In Worksheets
If ws.Name Like "Detail*" Then
X = Range("B15").Value
Select Case X
Case Is = "no"
Range("A1:AZ100").Select
With Selection.Interior
.ThemeColor = xlThemeColorAccent3
.TintAndShade = 0.799981688894314
End With
Range("B15").Select
With Selection.Interior
.Color = 5296274
End With
Case Is = "yes"
Range("A1:AZ100").Select
With Selection.Interior
.ThemeColor = xlThemeColorAccent2
.TintAndShade = 0.599993896298105
End With
Range("B15").Select
With Selection.Interior
.Color = 255
End With
Case Is = "yes/no"
Range("A1:AZ100").Select
With Selection.Interior
.ThemeColor = xlThemeColorAccent6
.TintAndShade = 0.799981688894314
End With
Range("B15").Select
With Selection.Interior
.Color = 65535
End With
End Select
End If
Next ws
End Sub
There is lots of ways to edit this code and make it more efficient, but to answer your question. ws.select would be required after line.If ws.Name Like "Detail*" Then
For Each ws In Worksheets
If ws.Name Like "Detail*" Then
ws.Select
X = Range("B15").Value
Select Case X
You can also use ws.Activate:
Sub Color_by_cell_value()
Dim X As String
Dim ws As Worksheet
Application.ScreenUpdating = False
For Each ws In Worksheets
If ws.Name Like "Detail*" Then
ws.Activate
X = Range("B15").Value
Select Case X
Case Is = "no"
Range("A1:AZ100").Select
With Selection.Interior
.ThemeColor = xlThemeColorAccent3
.TintAndShade = 0.799981688894314
End With
Range("B15").Select
With Selection.Interior
.Color = 5296274
End With
Case Is = "yes"
Range("A1:AZ100").Select
With Selection.Interior
.ThemeColor = xlThemeColorAccent2
.TintAndShade = 0.599993896298105
End With
Range("B15").Select
With Selection.Interior
.Color = 255
End With
Case Is = "yes/no"
Range("A1:AZ100").Select
With Selection.Interior
.ThemeColor = xlThemeColorAccent6
.TintAndShade = 0.799981688894314
End With
Range("B15").Select
With Selection.Interior
.Color = 65535
End With
End Select
End If
Next ws
Application.ScreenUpdating = True
End Sub
Note I also set the Application.ScreenUpdating to False as a good custom.

Excel VBA loop through intersections of pivot items and pivot field

I am trying to write a code that can apply conditional formatting to each intersection of two pivot fields separately. For example, I would like to select all entries for PartNumber 541-9037-100 in the "Average of TransA1" column, apply conditional formatting, then proceed to PartNumber, select all entries in the "Average of TransA1" column, apply conditional formatting, etc.
PartNumbers will vary from week to week, so I am looking for a generic code that will loop through every item in the PartNumber field.
I have tried to use a for loop, but seem to be selecting the entire Average of TransA1 column at once rather than the intersection of the Average of TransA1 column and each PartNumber item. A copy of my code is below- Can anyone help me revise my code to select only the intersections of the fields?
ConditionalFormatting2 Macro
'
' Select intersect of pivot table and output cell values to apply formatting
Dim pt As PivotTable
Set pt = Worksheets("Pivot Sheet").PivotTables("PivotTable2")
For Each PivotItem In pt.PivotFields("PartNumber").PivotItems
'Select the "Average of TransA1" column and apply conditional formatting
Application.PivotTableSelection = True
pt.PivotSelect "Average of TransA1", xlDataOnly
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent6
.TintAndShade = 0.399975585192419
.PatternTintAndShade = 0
End With
Selection.FormatConditions.AddTop10
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1)
.TopBottom = xlTop10Top
.Rank = 30
.Percent = True
End With
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent4
.TintAndShade = 0.399945066682943
End With
Selection.FormatConditions(1).StopIfTrue = False
Selection.FormatConditions.AddTop10
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1)
.TopBottom = xlTop10Top
.Rank = 10
.Percent = True
End With
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 8420607
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
Selection.FormatConditions.AddTop10
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1)
.TopBottom = xlTop10Bottom
.Rank = 30
.Percent = True
End With
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent4
.TintAndShade = 0.399945066682943
End With
Selection.FormatConditions(1).StopIfTrue = False
Selection.FormatConditions.AddTop10
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1)
.TopBottom = xlTop10Bottom
.Rank = 10
.Percent = True
End With
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 8420607
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
Next PivotItem
'
End Sub
strong text
Figured it out- it isn't pretty, but it works
'declare variables
Dim pt As PivotTable
Dim rng1 As Range
Dim rng2 As Range
Dim pn As String
Dim rw As Integer
Dim cntpi As Long
'Sets current worksheet, initializes rw and cntpi
Set pt = Worksheets("Pivot Sheet").PivotTables("PivotTable2")
rw = 5
cntpi = 0
'sets rng1 as the Average of TransA1 column
Range("A5").Select
Set rng1 = pt.PivotFields("Average of TransA1").DataRange.EntireColumn
'Loops through each part number, applies conditional formatting to all part number groups in data area
For Each PivotItem In pt.PivotFields("PartNumber").PivotItems
rw = rw + cntpi
Range(Cells(rw, 1), Cells(rw, 1)).Select
pn = Trim(ActiveCell.Value)
Set rng2 = pt.PivotFields("PartNumber").PivotItems(pn).DataRange.EntireRow
Intersect(rng1, rng2).Select
cntpi = Selection.Rows.Count
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 = 6737151
.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 = 6736896
.TintAndShade = 0
End With
Selection.FormatConditions(1).ColorScaleCriteria(3).Type = _
xlConditionValueHighestValue
With Selection.FormatConditions(1).ColorScaleCriteria(3).FormatColor
.Color = 6737151
.TintAndShade = 0
End With
Next PivotItem

How to conditional format data in multiple columns by hardcoding what the column's header name is?

I'm looking to run a series of conditional formatting rules on two columns of data. I know I can select a column letter and all the cells in that columns, but to make my macro more full-proof I'd like for it to search for the column's header and run the formatting on the cells below the two specific headers.
I Currently used the Record Macro tool to see how this could potentially work, and this is my current setup. This macro does work, I would just like to make it full-proof and search through the worksheet for the specific column title names. I'd like to search a woorksheet for the column Titles "Header 1" and "Header 2".
Sub TwoColumnConditional()
Columns("K:AJ").Select
Selection.FormatConditions.Add Type:=xlTextString, String:="CONTAINSTEXT1", _
TextOperator:=xlContains
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
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
Selection.FormatConditions.Add Type:=xlTextString, String:="CONTAINSTEXT2", _
TextOperator:=xlContains
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Font
.Color = -16751204
.TintAndShade = 0
End With
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 10284031
.TintAndShade = 0
End With
End Sub
Try this:
Sub ApplyCF()
Dim ws As Worksheet
Dim rng As Range, fcel As Range, hrng As Range
Dim myheaders, header
Dim mycondition As String
myheaders = Array("Header 1", "Header 2")
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
Set rng = .Range("A1", .Range("A1").Offset(0 _
, .Columns.Count - 1).End(xlToLeft).Address)
'Debug.Print headers.Address
End With
For Each header In myheaders
Set fcel = rng.Find(header, rng.Cells(rng.Cells.Count))
If Not fcel Is Nothing Then
If hrng Is Nothing Then
Set hrng = fcel.EntireColumn
Else
Set hrng = Union(hrng, fcel.EntireColumn)
End If
End If
Next
'Debug.Print hrng.address
hrng.FormatConditions.Add Type:=xlTextString, String:="CONTAINSTEXT1", _
TextOperator:=xlContains
With hrng.FormatConditions(hrng.FormatConditions.Count)
With .Font
.Color = -16383844
.TintAndShade = 0
End With
With .Interior
.PatternColorIndex = xlAutomatic
.Color = 13551615
.TintAndShade = 0
End With
.StopIfTrue = False
End With
hrng.FormatConditions.Add Type:=xlTextString, String:="CONTAINSTEXT2", _
TextOperator:=xlContains
With hrng.FormatConditions(hrng.FormatConditions.Count)
With .Font
.Color = -16751204
.TintAndShade = 0
End With
With .Interior
.PatternColorIndex = xlAutomatic
.Color = 10284031
.TintAndShade = 0
End With
.StopIfTrue = False
End With
End Sub
I only assumed your headers are in the first row.
Adjust the code to suit.