Loop Filter data and copy it with header to a new sheet

Question

I have data(Account numbers) in column D that I need to Loop filter this data, copy and paste filtered data into a new sheet.

I want to copy the filtered data with the header , also I want to copy all filtered data to 1 sheet , that new filtered data with its header goes under the last row and so on.

NB: My columns go from A to Z

How can I do that using VBA?

i tied the below code but it copies each filtered range to a new sheet, i want all copied data in 1 sheet under each other

Sub CopyFilteredDataToNewSheets()
      Dim r As Integer, Account As String
      With Worksheets("Sheet1")
          .Range("A1:Z1").AutoFilter
          For r = 2 To 24
              Account = Sheets("Sheet1").Range("D" & r).Value
              On Error Resume Next
              If Sheets(Account) Is Nothing Then
                  .Range("A1:Z1").AutoFilter Field:=4, Criteria1:=Account
                  .Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy
                  Sheets.Add.Name = Account
                  Sheets(Account).Paste
                  .ShowAllData
              End If
          Next r
      End With
  End Sub

Answer 1

Copy Filtered Ranges One Below the Other

Sheet1 (Before)

Sheet2 (After)

The Code

Sub CreateSummary()
    
    ' Define constants.
    
    ' Source
    Const SOURCE_NAME As String = "Sheet1"
    Const SOURCE_FIRST_CELL_ADDRESS As String = "A1"
    Const SOURCE_FILTER_COLUMN_INDEX As Long = 4
    ' Destination
    Const DESTINATION_NAME As String = "Sheet2"
    Const DESTINATION_FIRST_CELL_ADDRESS As String = "A1"
    Const DESTINATION_GAP As Long = 1 ' empty rows in-between

    ' Reference the workbook ('wb').
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Reference the source range ('srg').
    
    Dim sws As Worksheet: Set sws = wb.Worksheets(SOURCE_NAME)
    If sws.AutoFilterMode Then sws.AutoFilterMode = False ' turn off AutoFilter
    
    Dim srg As Range
    Set srg = sws.Range(SOURCE_FIRST_CELL_ADDRESS).CurrentRegion
    
    Dim srCount As Long: srCount = srg.Rows.Count
    If srCount = 1 Then Exit Sub ' only headers or empty worksheet
    
    Dim scCount As Long: scCount = srg.Columns.Count
    If scCount < SOURCE_FILTER_COLUMN_INDEX Then Exit Sub ' too few columns
    
    ' Write the values from the filter column ('srfg') to an array ('sData').
    
    Dim sfrg As Range: Set sfrg = srg.Columns(SOURCE_FILTER_COLUMN_INDEX)
    Dim sData() As Variant: sData = sfrg.Value
    
    ' Return the unique values and their number of occurrences
    ' in a dictionary ('dict').
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    
    Dim sString As String
    Dim sr As Long
    
    For sr = 2 To srCount
        sString = CStr(sData(sr, 1))
        If Len(sString) > 0 Then dict(sString) = dict(sString) + 1 ' count
    Next sr
    
    If dict.Count = 0 Then Exit Sub ' only error values or blanks
    Erase sData
    
    ' Reference the first destination cell ('dCell').
    
    Application.ScreenUpdating = False
    
    Dim dsh As Object
    On Error Resume Next
        Set dsh = wb.Sheets(DESTINATION_NAME)
    On Error GoTo 0
    If Not dsh Is Nothing Then
        Application.DisplayAlerts = False
            dsh.Delete
        Application.DisplayAlerts = True
    End If
    
    Dim dws As Worksheet: Set dws = wb.Worksheets.Add(After:=sws)
    dws.Name = DESTINATION_NAME
    Dim dCell As Range: Set dCell = dws.Range(DESTINATION_FIRST_CELL_ADDRESS)
    
    ' Copy column widths.
    
    srg.Rows(1).Copy
    dCell.Resize(, scCount).PasteSpecial xlPasteColumnWidths
    dCell.Select
    
    ' Copy the filtered ranges one below the other.
    
    Dim sKey As Variant
    
    For Each sKey In dict.Keys
        srg.AutoFilter SOURCE_FILTER_COLUMN_INDEX, sKey
        srg.Copy dCell
        sws.ShowAllData
        Set dCell = dCell.Offset(DESTINATION_GAP + dict(sKey) + 1)
    Next sKey
    
    sws.AutoFilterMode = False
    'wb.Save
    
    Application.ScreenUpdating = True
        
    ' Inform.
        
    MsgBox "Summary created.", vbInformation
    
End Sub