Loop though over the sheets and filter VBA-CodePudding

Trying to loop though the worksheets to apply the filter on date, and copy all the filtered data into a "Report" sheet.

Here is code, which loops only the first sheet ( USD) and not the second one (EUR).

Sub SheetLoop()

Dim Ws As Worksheet
Dim wb As Workbook
Dim DestSh As Worksheet
Dim Rng As Range
Dim CRng As Range
Dim DRng As Range


Set wb = ThisWorkbook
Set DestSh = wb.Worksheets("Report")

Set CRng = DestSh.Range("L1").CurrentRegion
Set DRng = DestSh.Range("A3")

For Each Ws In wb.Worksheets
    If Ws.Name <> DestSh.Name Then
    Set Rng = Ws.Range("A1").CurrentRegion
    
    Rng.AdvancedFilter xlFilterCopy, CRng, DRng
    
    End If
    
    
Next Ws

End Sub

CodePudding user response：

Since AdvancedFilter needs the filtered range headers, you cannot copy only part of the filtered range, but you can delete the first row of the copied range, except the first copied range (from first sheet):

Sub SheetLoop()
 Dim Ws As Worksheet, wb As Workbook, DestSh As Worksheet
 Dim Rng As Range, CRng As Range, DRng As Range, i As Long

  Set wb = ThisWorkbook
 Set DestSh = wb.Worksheets("Report")

 Set CRng = DestSh.Range("L1").CurrentRegion
 Set DRng = DestSh.Range("A3")

 For Each Ws In wb.Worksheets
    If Ws.name <> DestSh.name Then
        i = i   1
        Set Rng = Ws.Range("A1").CurrentRegion
        
        Rng.AdvancedFilter xlFilterCopy, CRng, DRng
        If i > 1 Then DRng.cells(1).EntireRow.Delete xlUp  'delete the first row of the copied range, except the first case
        Set DRng = DestSh.Range("A" & DestSh.rows.count).End(xlUp).Offset(1) 'reset the range where copying to
    End If
 Next Ws
 
 MsgBox "Ready..."
End Sub