VBA .Findnext stuck on Loop

Question

i 've been trying to make a macro to highlight dates with their entire rows if they fell into a specific date interval. The problem i have encoutered is : when macro finds a certain date it colours the entire row of that date and then should go onto the next .find with .findnext. However the macro gets stuck in a loop in here

Do While Not c Is Nothing
     c.EntireRow.Interior.Color = vbCyan
     Set c = Dates.FindNext
Loop

with c value as 2021.03.01 (as StartDate) My code looks like this:

        Private Sub CommandButton2_Click()
Dim c As Range
Dim first As String
Dim last As String
Dim StartDate As Date
Dim EndDate As Date
Dim DateLooper As Date

    first = CLng(Range("E2").Value)
    last = CLng(Range("G2").Value)

For Each Cell In ActiveSheet.Range("H2:H" & Cells(Rows.Count, 8).End(xlUp).Row)
  Sheet = Cell
  StartDate = first
  EndDate = last

  For DateLooper = StartDate To EndDate
    Set Dates = Worksheets(Sheet).Range("P:P")
    Set c = Dates.Find(What:=DateLooper)

        Do While Not c Is Nothing
        c.EntireRow.Interior.Color = vbCyan
        Set c = Dates.FindNext(c)
        Loop

  Next DateLooper
Set c = Nothing
Next Cell
End Sub

What's the problem here? Thank you for your time and help. Maybe it's because of the c being a date?

Answer 1

iadd fAddress variable and condition to loop

Private Sub CommandButton2_Click()
Dim c As Range
Dim first As String
Dim last As String
Dim StartDate As Date
Dim EndDate As Date
Dim DateLooper As Date
dim fAddress as String
    first = CLng(Range("E2").Value)
    last = CLng(Range("G2").Value)

For Each Cell In ActiveSheet.Range("H2:H" & Cells(Rows.Count, 8).End(xlUp).Row)
  Sheet = Cell
  StartDate = first
  EndDate = last

  For DateLooper = StartDate To EndDate
    Set Dates = Worksheets(Sheet).Range("P:P")
    Set c = Dates.Find(What:=DateLooper)
    if not c is nothing then 
        fAddress  = c.address
        Do 
           c.EntireRow.Interior.Color = vbCyan
           Set c = Dates.FindNext(c)
        Loop While Not c Is Nothing and fAddress  <> c.address
    end if
  Next DateLooper
Set c = Nothing
Next Cell
End Sub

Answer 2

Try the next way, please. Not tested, but it should be fast enough. It iterates between an array elements and put the range to be colored in a Union range, to be colored at once, at the end:

Private Sub CommandButton2_Click()
 Dim StartDate As Date, rngCol As Range, EndDate As Date
 Dim firstRow As Long, arrD, i As Long, rngH As Range

 Set rngH = Range("H2:H" & cells(rows.count, 8).End(xlUp).row)
 arrD = rngH.value
 StartDate = Range("E2").value
 EndDate = Range("G2").value
 firstRow = rngH.Find(what:=Date, LookIn:=xlValues, lookat:=xlWhole).row - 1lookat:=xlWhole).row - 1
  For i = firstRow To UBound(arrD)
    If CDate(arrD(i, 1)) = EndDate Then Exit For
    If CDate(arrD(i, 1)) = StartDate Then
        If rngCol Is Nothing Then
            Set rngCol = cells(i + 1, 1)
        Else
            Set rngCol = Union(rngCol, cells(i + 1, 1))
        End If
    End If
  Next i
  If Not rngCol Is Nothing Then rngCol.EntireRow.Interior.Color = vbCyan
End Sub

It assumes that the H:H column is sorted ascendant.

Answer 3

Highlight Entire Rows of Cells With Criteria

• Writes the start and end dates to variables (E2, G2).
• Loops through a column (H) range containing worksheet names.
• In each of those worksheets (dws), loops through the dates (DateLooper), and attempts to find the date in cells (dCell) of the date column (P).
• If found, highlights the cell's entire row.

The Code

Option Explicit

Private Sub CommandButton2_Click()
    
    Dim ws As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    Dim sws As Worksheet: Set sws = ActiveSheet
    Dim StartDate As Date: StartDate = sws.Range("E2").Value
    Dim EndDate As Date: EndDate = sws.Range("G2").Value
    Dim wrg As Range
    Set wrg = sws.Range("H2", sws.Cells(sws.Rows.Count, "H").End(xlUp))
    
    Dim dws As Worksheet
    Dim drg As Range
    Dim dCell As Range
    Dim wCell As Range
    Dim DateLooper As Date
    Dim fAddr As String
    
    For Each wCell In wrg.Cells ' loop through list of worksheet names
        Set dws = wb.Worksheets(wCell.Value)
        Set drg = dws.Range("P2", dws.Cells(dws.Rows.Count, "P").End(xlUp))
        For DateLooper = StartDate To EndDate ' loop through dates
            Set dCell = drg.Find(What:=DateLooper) ' find dates
            If Not dCell Is Nothing Then
                fAddr = dCell.Address
                Do
                    dCell.EntireRow.Interior.Color = vbCyan
                    Set dCell = drg.FindNext(dCell)
                Loop Until dCell.Address = fAddr
            End If
            Set dCell = Nothing
        Next DateLooper
    Next wCell

End Sub