遍历列过滤时可见的数据

Question

以下代码是我经过大量研究和努力后编写的，但是我现在发现这没有用，因为我在 worksheetsheet 中有多个过滤器。我不想遍历工作表中的所有数据，我只想遍历过滤时可见的数据。但是，使用我的代码，它会遍历所有行。我一次最多过滤 5 列。

在dt = CDate(Sheets("Sheet5").Range("P2").Value) 中，我给出了 P2，但是当我过滤它时它可能不可见，并且我不想检查此单元格中的数据。

Sub FindDuration()

Dim totalDuration As Single
Dim dt As Date
Dim nextDt As Date
Dim maxDt As Date
Dim DateDiff
Dim lr As Long
Dim lrw As Long
Dim lr1 As Long
Dim i As Long

totalDuration = 0
dt = 0
lr1 = ThisWorkbook.Sheets("Sheet5").Range("A" & Rows.Count).End(xlUp).Row

dt = CDate(Sheets("Sheet5").Range("P2").Value)
maxDt = dt + 1
  
For i = 2 To lr1

    DateDiff = maxDt - dt
 
    If DateDiff <= 1 And nextDt <= maxDt Then
        totalDuration = totalDuration + Sheets("Sheet5").Range("G" & i).Value
        nextDt = CDate(Sheets("Sheet5").Range("P" & i + 1).Value)
    Else
        lrw = ThisWorkbook.Sheets("Chart").Range("A" & Rows.Count).End(xlUp).Row
        Sheets("Chart").Range("A" & lrw + 1).Value = totalDuration
        totalDuration = Sheets("Sheet5").Range("G" & i).Value
        dt = CDate(Sheets("Sheet5").Range("P" & i).Value)
        maxDt = dt + 1

    End If

Next i
lrw = ThisWorkbook.Sheets("Chart").Range("A" & Rows.Count).End(xlUp).Row
Sheets("Chart").Range("A" & lrw + 1).Value = totalDuration

End Sub

我知道这段代码并不完美，因为我不是 VBA 专家。

编辑：

您在下图中看到的只是示例数据。 J 和 K 列中的值（在我们的代码 G 和 P 中）是我们所拥有的 L、N、O 是我们想要的。我们几乎已经用我们的代码完成了“要添加的总持续时间”，而 N 和 O 列是我遇到问题的地方。

Answer 1

循环过滤的数据行

• 未经测试。

Option Explicit

Sub FindDuration()
    
    Dim wb As Workbook: Set wb = ThisWorkbook
    
    ' Source
    Dim sws As Worksheet: Set sws = wb.Worksheets("Sheet5")
    Dim slRow As Long: slRow = sws.Range("A" & sws.Rows.Count).End(xlUp).Row
    Dim slCol As Long
    slCol = sws.Cells(1, sws.Columns.Count).End(xlToLeft).Column
    Dim srg As Range: Set srg = sws.Range("A2", sws.Cells(slRow, slCol))
    Dim svrg As Range: Set svrg = srg.SpecialCells(xlCellTypeVisible)
    
    ' Destination
    Dim dws As Worksheet: Set dws = wb.Worksheets("Chart")
    Dim dCell As Range
    Set dCell = dws.Range("A" & dws.Rows.Count).End(xlUp).Offset(1)
    
    Dim sarg As Range
    Dim srrg As Range
    Dim dt As Date
    Dim dtNext As Date
    Dim dtMax As Date
    Dim dtDiff As Double ' possibly 'As Long' ???
    Dim totalDuration As Double
    Dim IsNotFirst As Boolean
    Dim DoGetNextDate As Boolean
    
    For Each sarg In svrg.Areas
        
        For Each srrg In sarg.Rows
            
            If Not IsNotFirst Then
                dt = CDate(srrg.Columns("P").Value)
                dtMax = dt + 1
                IsNotFirst = True
            End If
            
            dtDiff = dtMax - dt
            
            If DoGetNextDate Then
                dtNext = CDate(srrg.Columns("P").Value)
            End If
            
            If dtDiff <= 1 And dtNext <= dtMax Then
                totalDuration = totalDuration + srrg.Columns("G").Value
                DoGetNextDate = True
            Else
                dCell.Value = totalDuration
                Set dCell = dCell.Offset(1)
                totalDuration = srrg.Columns("G").Value
                dt = CDate(srrg.Columns("P").Value)
                dtMax = dt + 1
                DoGetNextDate = False
            End If
        
        Next srrg
    
    Next sarg

    'dcell.Value = totalDuration ' not quite sure???
     
End Sub