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（作为开始日期）我的代码如下所示：

        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

iadd 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

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

使用条件突出显示整行单元格

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

代码

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

VBA .Findnext 卡在循环中

VBA .Findnext stuck on Loop

excel

vba

loops

date

find

使用条件突出显示整行单元格