VBA Macro to fill in cells if date and text criteria is met

[slohman]

Ok I am starting to get somewhere but need a bit more help

This is the code I am using in another part of my worksheet and it works great. I just need to be able to add modify or create new for next part of worksheet

Sub CondFormatMultiColour()
Application.ScreenUpdating = False

Dim wrkSchedule As Worksheet
Dim RangeA As Range, RangeF As Range, FoundWordCell As Range, Cl As Range
Dim TopRow As Long, BottomRow As Long, FoundRow As Long
Dim Booked As String
Dim Forpark As String
Dim Status As String, Word2Find1 As String, Word2Find2 As String, Word2Find3 As String, Word2Find4 As String, Word2Find5 As String, Word2Find6 As String, Word2Find7 As String, Word2Find8 As String, Word2Find9 As String, Word2Find10 As String, Word2Find11 As String, Word2Find12 As String ' Add more if you want more

Word2Find1 = "Description"
Word2Find2 = "Dial"
Word2Find3 = "Install" ' Can change these to cell ranges if you want
Word2Find4 = "Underground"    ' to change the searched words easier but
Word2Find5 = "Special" ' requires a bit more code
Word2Find6 = "Play Audit"
Word2Find7 = "Bob Cat - Excavate"
Word2Find8 = "Bob Cat - Removal of Equipment"
Word2Find9 = "Bob Cat - Removal of Edging"
Word2Find10 = "Bob Cat - Removal of Mulch"
Word2Find11 = "Soil Dump"
Word2Find12 = "Bin Hire"
Status = LCase("Status")
Booked = LCase("Booked")
Set wrkSchedule = ThisWorkbook.Sheets(1) ' The worksheet

TopRow = 3 ' Highest row of data
'  Find the bottom row of data
BottomRow = wrkSchedule.Columns(1).Find(What:="*", LookIn:=xlValues, LookAt:=xlPart, _
                        SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False, _
                        SearchFormat:=False).Row

'  Set the range for the loop
Set RangeA = wrkSchedule.Range(wrkSchedule.Cells(TopRow, 1), wrkSchedule.Cells(BottomRow, 1))

'  Start The Loop
    With RangeA
        For Each Cl In RangeA
          
          
            If InStr(1, LCase(Cl), LCase(Word2Find1), 1) > 0 Then
                Set FoundWordCell = wrkSchedule.Cells(Cl.Row, 1)
            If LCase(FoundWordCell.Offset(0, 5)) = Status Then
                Set RangeF = wrkSchedule.Range(wrkSchedule.Cells(Cl.Row, 1), wrkSchedule.Cells(Cl.Row, 13))
                With RangeF
                    .Interior.Color = RGB(217, 217, 217) ' Lightish Grey (Description)
                  
                End With
            End If
          
            ElseIf InStr(1, LCase(Cl), LCase(Word2Find2), 1) > 0 Then
                Set FoundWordCell = wrkSchedule.Cells(Cl.Row, 1)
            If LCase(FoundWordCell.Offset(0, 5)) = Booked And IsDate(FoundWordCell.Offset(0, 10)) Then
                Set RangeF = wrkSchedule.Range(wrkSchedule.Cells(Cl.Row, 1), wrkSchedule.Cells(Cl.Row, 13))
      
                With RangeF
                    .Interior.Color = RGB(51, 204, 255) ' Aqua Blue (Dial)
                End With
            End If
          
            ElseIf InStr(1, LCase(Cl), LCase(Word2Find3), 1) > 0 Then
                Set FoundWordCell = wrkSchedule.Cells(Cl.Row, 1)
            If LCase(FoundWordCell.Offset(0, 5)) = Booked And IsDate(FoundWordCell.Offset(0, 10)) Then
                Set RangeF = wrkSchedule.Range(wrkSchedule.Cells(Cl.Row, 1), wrkSchedule.Cells(Cl.Row, 13))
      
                With RangeF
                    .Interior.Color = RGB(255, 255, 0) ' Yellow (Install)
                End With
            End If
          
            ElseIf InStr(1, LCase(Cl), LCase(Word2Find4), 1) > 0 Then
                Set FoundWordCell = wrkSchedule.Cells(Cl.Row, 1)
            If LCase(FoundWordCell.Offset(0, 5)) = Booked And IsDate(FoundWordCell.Offset(0, 10)) Then
                Set RangeF = wrkSchedule.Range(wrkSchedule.Cells(Cl.Row, 1), wrkSchedule.Cells(Cl.Row, 13))

                With RangeF
                    .Interior.Color = RGB(255, 0, 0) '  Red (Underground)
                End With
            End If
          
            ElseIf InStr(1, LCase(Cl), LCase(Word2Find5), 1) > 0 Then
                Set FoundWordCell = wrkSchedule.Cells(Cl.Row, 1)
            If LCase(FoundWordCell.Offset(0, 5)) = Booked And IsDate(FoundWordCell.Offset(0, 10)) Then
                Set RangeF = wrkSchedule.Range(wrkSchedule.Cells(Cl.Row, 1), wrkSchedule.Cells(Cl.Row, 13))

                With RangeF
                    .Interior.Color = RGB(128, 128, 0) ' Lightish Green (Special)
                End With
            End If
          
            ElseIf InStr(1, LCase(Cl), LCase(Word2Find6), 1) > 0 Then
                Set FoundWordCell = wrkSchedule.Cells(Cl.Row, 1)
            If LCase(FoundWordCell.Offset(0, 5)) = Booked And IsDate(FoundWordCell.Offset(0, 10)) Then
                Set RangeF = wrkSchedule.Range(wrkSchedule.Cells(Cl.Row, 1), wrkSchedule.Cells(Cl.Row, 13))

                With RangeF
                    .Interior.Color = RGB(255, 153, 204) ' Lightish Pink (Play Audit)
                End With
            End If
          
            ElseIf InStr(1, LCase(Cl), LCase(Word2Find7), 1) > 0 Then
                Set FoundWordCell = wrkSchedule.Cells(Cl.Row, 1)
            If LCase(FoundWordCell.Offset(0, 5)) = Booked And IsDate(FoundWordCell.Offset(0, 10)) Then
                Set RangeF = wrkSchedule.Range(wrkSchedule.Cells(Cl.Row, 1), wrkSchedule.Cells(Cl.Row, 13))

                With RangeF
                    .Interior.Color = RGB(148, 138, 84) ' Lightish Brown (Bob Cat - Excavate)
                End With
            End If
          
            ElseIf InStr(1, LCase(Cl), LCase(Word2Find8), 1) > 0 Then
                Set FoundWordCell = wrkSchedule.Cells(Cl.Row, 1)
            If LCase(FoundWordCell.Offset(0, 5)) = Booked And IsDate(FoundWordCell.Offset(0, 10)) Then
                Set RangeF = wrkSchedule.Range(wrkSchedule.Cells(Cl.Row, 1), wrkSchedule.Cells(Cl.Row, 13))

                With RangeF
                    .Interior.Color = RGB(77, 197, 71) ' Lightish Green (Bob Cat - Removal of Equipment)
                End With
            End If
          
            ElseIf InStr(1, LCase(Cl), LCase(Word2Find9), 1) > 0 Then
                Set FoundWordCell = wrkSchedule.Cells(Cl.Row, 1)
            If LCase(FoundWordCell.Offset(0, 5)) = Booked And IsDate(FoundWordCell.Offset(0, 10)) Then
                Set RangeF = wrkSchedule.Range(wrkSchedule.Cells(Cl.Row, 1), wrkSchedule.Cells(Cl.Row, 13))

                With RangeF
                    .Interior.Color = RGB(51, 153, 51) ' Lightish Green (Bob Cat - Removal of Edging)
                End With
            End If
          
            ElseIf InStr(1, LCase(Cl), LCase(Word2Find10), 1) > 0 Then
                Set FoundWordCell = wrkSchedule.Cells(Cl.Row, 1)
            If LCase(FoundWordCell.Offset(0, 5)) = Booked And IsDate(FoundWordCell.Offset(0, 10)) Then
                Set RangeF = wrkSchedule.Range(wrkSchedule.Cells(Cl.Row, 1), wrkSchedule.Cells(Cl.Row, 13))

                With RangeF
                    .Interior.Color = RGB(51, 137, 60) ' Darkish Green (Bob Cat - Removal of Mulch)
                End With
            End If
          
            ElseIf InStr(1, LCase(Cl), LCase(Word2Find11), 1) > 0 Then
                Set FoundWordCell = wrkSchedule.Cells(Cl.Row, 1)
            If LCase(FoundWordCell.Offset(0, 5)) = Booked And IsDate(FoundWordCell.Offset(0, 10)) Then
                Set RangeF = wrkSchedule.Range(wrkSchedule.Cells(Cl.Row, 1), wrkSchedule.Cells(Cl.Row, 13))

                With RangeF
                    .Interior.Color = RGB(226, 107, 10) ' Lightish Apricot (Soil)
                End With
            End If
          
            ElseIf InStr(1, LCase(Cl), LCase(Word2Find12), 1) > 0 Then
                Set FoundWordCell = wrkSchedule.Cells(Cl.Row, 1)
            If LCase(FoundWordCell.Offset(0, 5)) = Booked And IsDate(FoundWordCell.Offset(0, 10)) Then
                Set RangeF = wrkSchedule.Range(wrkSchedule.Cells(Cl.Row, 1), wrkSchedule.Cells(Cl.Row, 13))

                With RangeF
                    .Interior.Color = RGB(255, 255, 102) ' Lightish ??? (Bin Hire)
                End With
            End If
          

            End If
        Next Cl
'  Delete code between the hashes if you dont want it
'#############################################
            If Nothing Is Cl Then
                                End
            Else
                MsgBox "Macro Finished Early ??"
                End
            End If
'#############################################
    End With

End Sub

I need it now to look at Column P:BS to see if =AND($J2>0,$A2="Dial before you Dig",P$1>=$J2,P$1<=$K2) and it will fill in Date Columns as per my attachment

 

[slohman]

Can anybody help with this?

 

[Smallman]

Hi Slohman

Just looking at your code above. Will get to the other bit, can you confirm that the following replicates all of your code above.

Option Explicit

Sub ColourMe()
Dim ar As Variant
Dim var As Variant
Dim fnd As Range
Dim i As Integer

ar = Sheet3.[B2:B26]
var = Sheet3.[C2:E26]

    For i = 1 To Sheet3.Range("A" & Rows.Count).End(xlUp).Row - 1
        Set fnd = Range("A:A").Find(ar(i, 1), , , xlPart)
        If Not fnd Is Nothing Then fnd.Resize(, 13).Interior.Color = RGB(var(i, 1), var(i, 2), var(i, 3))
    Next i
End Sub

I can't find anything in J2 or K2 in your file. What data is meant to be there?

Workbook attached to show workings.



Take care

Smallman

 

[slohman]

Firstly the code that you wrote is great but I need it to colour if all these criteria's are met not just Column A.

The code that I attached works great but I need now to move further along and start putting in schedule dates likes a gantt chart. The below was a conditional format and I have as many as 25 so I though incorporating this into a macro would be much easier.

=AND($J5>0,$A5="Dial before you Dig",P$1>=$J5,P$1<=$K5)

I made the worksheet small and with less text as it can go as far as A700 depends on how many jobs I have running at the time. It will always start at A5 the above 4 rows are headers and titles.

 

[Smallman]

My code does not just colour col a. It covers off col a and 13 additional cols. Same as yours and with about 100 less lines. It is easier to read and the large slab of code you posted was the reason your thread was largely ignored.

The formula above is different to your original. What cell are you putting it in so I can replicate the problem. Or upload a fresh file. That will help muchly.

Take care

Smallman

 

[slohman]

In my code it looks for the Word Dial (for instance) in Column A and then Column F if the word Booked and then Column J if date all 3 of these have to be filled in for the colouring to be attached.

In the other matter I need it look for the same in Column A and then if look at Column J and P and if they are the same and Column K and P and they will highlight in my column from P5 onto BS5 down to end.

If you look at your worksheet you did it shows colouring in those columns but is done all by conditional formatting.

 

[slohman]

Hi Smallman
Just wondering if you had a chance to look at this,
Thanks

 

[Smallman]

Hi Slohman

I left my city for a wedding a couple of days ago and am at a place with net connection but no XL. I am pretty much hamstrung on this problem till I can get some of the Smooth Microsoft Music we all call Excel.

I am so sorry but will do my best.

Take care

Smallman

 

[slohman]

Thank you very much for your help

 

[slohman]

I also found something on your original macro it only shows the first of any of the criteria but runs down the length of my sheet to end and highlights only 1 of each.

I have multiple times Dial or Special or Underground is in Column A. I also have blank lines in column A so I dont know if that has something to do with it.