Conditional formatting (exact criteria and multiple columns) - vba

I'm an excel vba noob and I'm quite stuck at this code wherein I need to format cells containing a specific criteria for multiple columns.
For example I would need to highlight all values except the cells which contains "Complete" into YELLOW with BOLD RED FONT.
I've tried to just record it by simply filtering out "Complete" and highlighting all other values but I would need it to be dynamic.
Sub Macro1()
ActiveSheet.Range("$A$1:$W$6114").AutoFilter Field:=6, Criteria1:= _
"=Incomplete", Operator:=xlOr, Criteria2:="="
Range("F171").Select
Range(Selection, Selection.End(xlDown)).Select
Range("F171:F6114").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Selection.Font
.Color = -16776961
.TintAndShade = 0
End With
Selection.Font.Bold = True
End Sub
Will be grateful for any assistance!

Try this:
Sub Macro1()
Dim rng As Range
Set rng = ActiveSheet.Range("A1").CurrentRegion
With rng
.AutoFilter Field:=6, Criteria1:="<>Complete", Operator:=xlAnd
End With
With rng.Range(Cells(2, 6), Cells(rng.Rows.Count, 6)).SpecialCells(xlCellTypeVisible)
With .Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = vbYellow
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With .Font
.Color = vbRed
.TintAndShade = 0
.Bold = True
End With
End With
End Sub

Related

VBA syntax to reference cell on same row inside conditional format

I'm trying to create a VBA Macro to automate part of a large process. I can do it manually but it isn't practical as there are 27K rows.
I have a range of dates in columns F through AC. I'm trying to use conditional formatting to color the ones that fall between the dates in columns A and B on the same row. IE: Row 2 (1 is headers) A2 and B2 are dates that span one year. F2:AC2 are filled with dates that may or may not fall in that range. Turn the ones that do red (pink red text or what ever). Continue for the next 27K rows.
What I have is working on a 57 item sample Except that it only references the original hard coded selections from the macro recording. I'm struggling with the syntax to make it dynamic.
[code]Sub Conditions()
'
' Conditional format
'
Dim x As Integer
Application.ScreenUpdating = False
NumRows = Range("F2", Range("F2").End(xlDown)).Rows.Count
'Range("F2").Select
'Range(("F2"), Selection.End(xlToRight)).Select
Range("F2").Select
Range(("F2"), Selection.End(xlToRight)).Select
For x = 1 To NumRows
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlBetween, _
Formula1:="=$A$2", Formula2:="=$B$2"
'Formula1:="=ActiveCell.Offset(0,-5)", Formula2:="=ActiveCell.Offset(0,-4)" '<---- offset from active cell
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
ActiveCell.Offset(1, 0).Select
Range(ActiveCell, ActiveCell.End(xlToRight)).Select
Next
Application.ScreenUpdating = True
End Sub [code]
Any help is appreciated.
this worked perfectly.
Sub Conditions2()
Dim numrows As Long
Range("F2").Select
numrows = Range("F2", Range("F2").End(xlDown)).Rows.Count
With Range("F2", Range("F2").End(xlToRight)).Resize(numrows)
With .FormatConditions.Add(Type:=xlCellValue, Operator:=xlBetween, Formula1:="=$A2", Formula2:="=$B2")
.SetFirstPriority
With .Font
.Color = -16383844
.TintAndShade = 0
End With
With .Interior
.PatternColorIndex = xlAutomatic
.Color = 13551615
.TintAndShade = 0
End With
.StopIfTrue = False
End With
End With
End Sub

Excel/ how to connect buttons on different worksheets

my first button (Schaltfläche 83)
Other button which I want to activate vom "Hirata Bestellformular"
1st option: the top blue one
2nd option: the big one (activexelement)
I want to activate one button from another worksheet because I want to execute the code below on the worksheet "Teileliste" directly from "Hirata Bestellformular". How can I accomplish this?
Sub Teileliste_generieren()
' advanced filter
Sheets("Hirata Bestellformular").Range("Tabelle3[[#Headers],[#Data]]"). _
AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range("B50:B51"), _
CopyToRange:=Range("B54:B55"), Unique:=False
Range("B5").Select
ActiveCell.FormulaR1C1 = _
"=IFERROR(LEFT(R[50]C,FIND(CHAR(10),R[50]C)-1),R[50]C)"
Range("B6").Select
ActiveCell.FormulaR1C1 = _
"=IFERROR(LEFT(R[50]C,FIND(CHAR(10),R[50]C)-1),R[50]C)"
Range("B5:B6").Select
Selection.AutoFill Destination:=Range("B5:B26"), Type:=xlFillDefault
Range("B5:B26").Select
Range("D22").Select
'formatierung tabelle
Range("B3").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 16763955
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("B4").Select
With Selection.Interior
.Pattern = xlSolid
.PatternThemeColor = xlThemeColorAccent3
.Color = 16777215
.TintAndShade = 0
.PatternTintAndShade = 0.799981688894314
End With
Range("B5").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 9868950
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("B6").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 15395562
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("B5:B6").Select
Selection.AutoFill Destination:=Range("B5:B26"), Type:=xlFillDefault
Range("B5:B26").Select
Range("D20").Select
' Wenn 0 blank
Range("B5:B26").Select
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
Formula1:="=0"
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Font
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End With
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
Range("C22").Select
' Exportieren
ThisWorkbook.Sheets("Teileliste").Copy
Application.GetSaveAsFilename
End Sub
I can try. :)
If I understand you, you want to be able to press Teileliste generieren from Hirata Bestellformular. This means that you still want the button Schaltfläche 83 do to the same thing as Teileliste generieren, but you don't want to switch sheets to press the button?
Then I believe your problem is in your Range.Select statements.
In Excels VBA Object Model, if you call Range("B50:B51").Select from the Teileliste-sheet, then it will automatically select that range in Teileliste-sheet. If do it from Hirata Bestellformular, then it will select Range("B50:B51") from Hirata Bestellformular instead.
This means: it should work if you change all your Range("...").Select to Worksheets("Teileliste").Range("...").Select
This has to do with the Excel VBA Object Model.
I'm pretty sure that should do the trick but it depends on where your code is placed (within the specific sheets or in a Module). Try replacing the Range.Selects and see if it helps. :)
Just A quick hint:
You can right-click the button Schaltfläche 83 and assign a macro to it. So in your case you can just right-click -> assign macro -> choose
Teileliste_generieren()
If your code can deal with being called on different sheets, then it Will work.
//from My iPhone
Sub Teileliste_generieren2()
' advanced filter
Sheets("Hirata Bestellformular").Range("Tabelle3[[#Headers],[#Data]]"). _
AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Worksheets("Teileliste").Range("B50:B51"), _
CopyToRange:=Worksheets("Teileliste").Range("B54:B55"), Unique:=False
Worksheets("Teileliste").Range("B5").Select
ActiveCell.FormulaR1C1 = _
"=IFERROR(LEFT(R[50]C,FIND(CHAR(10),R[50]C)-1),R[50]C)"
Worksheets("Teileliste").Range("B6").Select
ActiveCell.FormulaR1C1 = _
"=IFERROR(LEFT(R[50]C,FIND(CHAR(10),R[50]C)-1),R[50]C)"
Worksheets("Teileliste").Range("B5:B6").Select
Selection.AutoFill Destination:=Worksheets("Teileliste").Range("B5:B26"), Type:=xlFillDefault
Worksheets("Teileliste").Range("B5:B26").Select
Worksheets("Teileliste").Range("D22").Select
'formatierung tabelle
Worksheets("Teileliste").Range("B5").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark2
.TintAndShade = -0.249977111117893
.PatternTintAndShade = 0
End With
Worksheets("Teileliste").Range("B6").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent4
.TintAndShade = 0.799981688894314
.PatternTintAndShade = 0
End With
Worksheets("Teileliste").Range("B5:B6").Select
Selection.AutoFill Destination:=Worksheets("Teileliste").Range("B5:B26"), Type:=xlFillDefault
Worksheets("Teileliste").Range("B5:B26").Select
Worksheets("Teileliste").Range("C18").Select
' Wenn 0 blank
Worksheets("Teileliste").Range("B5:B26").Select
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
Formula1:="=0"
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Font
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End With
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
Worksheets("Teileliste").Range("C22").Select
' Exportieren
ThisWorkbook.Sheets("Teileliste").Copy
Application.GetSaveAsFilename
End Sub
I just replaced it everywhere like you said and it works if I aktivate the makro from "Teileliste" but there s error when I acctivate it from "Hiraa Bestellformular" saying: Error1004 he Select- Method of the Range-Object could not be executed:/ Another suggestion?:)

VBA Error 1004 Object Range failed for _Global

I need to make a little VBA Application for a School project.
I recorded a Macro which Resize all Cells and then make them green. After that I select specific Cells and recolor them in white. So the result should be the Excel logo. However when I run the code there is an Error 1004 Range Object failed for _Global.
Code:
Sub Resize()
Columns("A:BZ").ColumnWidth = 2.71
Rows("1:1000").RowHeight = 15
Cells.Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 4485149
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Union(Range( _
"O14:P15,L7:T7,S5:T6,P6:Q6,E38:F47,G46:J47,G42:J43,G38:J39,N38:O39,O40:R41,R38:S39,P42:Q43,O44:R45,N46:O47,R46:S47,W38:X47,Y46:AB47,Y38:AB39,AF38:AK39,AF40:AG47,AH46:AK47,AH42:AK43,AO38:AP47,AQ46:AT47,R6,Y7:AP9,AN10:AP31,Y29:AM31,AF10:AF28,AG24:AM24,Y24:AE24" _
), Range( _
"AG19:AM19,AG14:AM14,Y14:AE14,V4:X33,U5:U32,T12:T25,S14:S23,R16:R21,Q18:Q19,Q28:T32,M26:R27,N24:Q25,O22:P23,L28:P31,H28:K30,F9:G29,H8:J27,K12:K25,L14:L23,M16:M21,N18:N19,K8:T9,M10:R11,N12:Q13" _
)).Select
Cells.Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End Sub
the string fed to Range must be less then 256 characters, while your first range has just 257... so just shift some characters to the 2nd range
furthermore you're selecting all cells instead of wanted ones
see code:
Option Explicit
Sub Resize()
With Range("A1:BZ1000")
.ColumnWidth = 2.71
.RowHeight = 15
With .Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 4485149
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End With
With Union(Range( _
"O14:P15,L7:T7,S5:T6,P6:Q6,E38:F47,G46:J47,G42:J43,G38:J39,N38:O39,O40:R41,R38:S39,P42:Q43,O44:R45,N46:O47,R46:S47,W38:X47,Y46:AB47,Y38:AB39,AF38:AK39,AF40:AG47,AH46:AK47,AH42:AK43,AO38:AP47,AQ46:AT47,R6,Y7:AP9,AN10:AP31,Y29:AM31" _
), Range( _
"AF10:AF28,AG24:AM24,Y24:AE24,AG19:AM19,AG14:AM14,Y14:AE14,V4:X33,U5:U32,T12:T25,S14:S23,R16:R21,Q18:Q19,Q28:T32,M26:R27,N24:Q25,O22:P23,L28:P31,H28:K30,F9:G29,H8:J27,K12:K25,L14:L23,M16:M21,N18:N19,K8:T9,M10:R11,N12:Q13" _
)).Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End Sub

Excel How to find duplicate cells or values in a row?

I have a dataset in which each row belongs to a unique person so what I want to do is that find duplicate values in each row.
I tried using conditional formatting but its very time consuming as I have to apply it to each individual row otherwise it will find duplicates among all rows not just one row.
Could you please suggest something that can help me it can be formula or vba or formula for conditional formatting.
I used macro recorder to create a macro and the results is below. If I can make it go through a range of rows and apply the formatting that could help
Sub DuplicatesRow1() ' ' DuplicatesRow Macro '
'
Rows("251:251").Select
Selection.FormatConditions.AddUniqueValues
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
Selection.FormatConditions(1).DupeUnique = xlDuplicate
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
Rows("252:252").Select
Selection.FormatConditions.AddUniqueValues
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
Selection.FormatConditions(1).DupeUnique = xlDuplicate
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
Rows("253:253").Select
Selection.FormatConditions.AddUniqueValues
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
Selection.FormatConditions(1).DupeUnique = xlDuplicate
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
Range("E259").Select End Sub
I further worked on this and managed to come up with the following code which seems to be working for me. I am new to VBA and do not have enough experience so please let me know if my code can be improved further
Private Sub HighlightDuplicateRow(row As Integer)
Dim report As Worksheet
Set report = Excel.ActiveSheet
report.Cells(row, row).EntireRow.Select
Selection.FormatConditions.AddUniqueValues
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
Selection.FormatConditions(1).DupeUnique = xlDuplicate
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
End Sub
Sub DuplicatesInEachRow()
Dim counter As Integer, limit As Variant
counter = 2
limit = InputBox("Give me last row number", "Highlight Duplicates in a Row")
If limit = "" Then Exit Sub
Do Until counter > limit
Call HighlightDuplicateRow(counter)
counter = counter + 1
Loop
End Sub
Here is a loop that will set a conditional format on each row. I used sheet and range references based on your sample data and code. You modify these to fit your exact data set.
I will also note that I am concerned about this causing performance issues in Excel if there are numerous rows, as the amount of Formats may seriously raise your file size and affect performance.
Sub LoopCF()
Dim ws As Worksheet
Set ws = Sheets("Sheet1")
'Dim lRow As Long
'lRow = ws.Range("A2").End(xlDown).Row 'will give row 200 as long as contiguous rows
Dim rng As Range, cel As Range
Set rng = ws.Range("B2:B200") 'ws.Range("B2:B" & lRow)
For Each cel In rng
With cel.Resize(1, 4)
.FormatConditions.AddUniqueValues
.FormatConditions(.FormatConditions.Count).SetFirstPriority
With .FormatConditions(1)
.DupeUnique = xlDuplicate
With .Font
.Color = -16383844
.TintAndShade = 0
End With
With .Interior
.PatternColorIndex = xlAutomatic
.Color = 13551615
.TintAndShade = 0
End With
.StopIfTrue = False
End With
End With
Next
End Sub

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.