Loop through data that are visible when column filtered

user_13935956 0
Viewed 77

Following code, I wrote after a lot of research and hard work however I now found this is of no use as I have multiple filters in the worksheetsheet. I do not want to loop through all the data in the sheet, I want to loop through only the data that are visible when filtered. But, with my code it loops through all the rows. At a time I have up to 5 columns filtered.

In dt = CDate(Sheets("Sheet5").Range("P2").Value) I have given P2 but when I filter it might not be visible and I do not want to check data in this cell.

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

I know this code is not perfect because I am not an expert in VBA.

Edit:

What you can see in the image below is just sample data. Value in the Columns J and K (in our code G and P) is what we have L, N, O is what we want. We have almost accomplished 'Total Duration to add' with our code and with columns N and O is where I have the issue.

enter image description here

vba excel
1 Answers

Loop Through Rows of Filtered Data

  • Not tested.
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
user_98140690
Related