VBA .Findnext 卡在循环上

Question

我一直在尝试制作一个宏来突出显示整个行的日期，如果它们落入特定的日期间隔。我遇到的问题是：当宏找到某个日期时，它会为该日期的整行着色，然后应该使用 .findnext 进入下一个 .find。但是宏在这里陷入了循环

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

c 值为 2021.03.01（作为 StartDate） 我的代码如下所示：

        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

这里有什么问题？感谢您的时间和帮助。 也许是因为 c 是一个日期？

Answer 1

使用标准突出显示整行单元格

• 将开始和结束日期写入变量（E2、G2）。
• 循环遍历包含工作表名称的列 (H)。
• 在每个工作表 (dws) 中，循环访问日期 (DateLooper)，并尝试在日期列 (P) 的单元格 (dCell) 中查找日期。
• 如果找到，突出显示单元格的整行。

守则

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

Answer 2

请尝试下一个方法。未经测试，但它应该足够快。它在数组元素之间迭代，并将要着色的范围放在一个联合范围中，一次着色，最后：

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

假设 H:H 列按升序排序。

Answer 3

将 fAddress 变量和条件添加到循环

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