VBA to copy N rows to new page per filtered page-CodePudding

I am a new stack overflow usere so if anything is not correct with this post please let me know.

I have code that filters by Company ID (Column 4) then pastes to a new sheet. I need to create a text file upload that can only contain four of each Company ID per sheet. Is it possible using vba to copy the first four filtered rows to a new sheet, then the next four rows to another sheet, until the filtered rows are all copied then filter for the next ID and copy to the same newly created worksheets?

This is the code I am currently using and it filters and creates a new ws for each Company Id

Sub Newly_Boarded()
'
' Newly_Boarded Macro
'

Dim LastRow As Long, LastCol As Integer, i As Long, iStart As Long, iEnd As Long
Dim ws As Worksheet, iCol As Integer
Dim sh As Worksheet, Master As String
iCol = 4
Application.ScreenUpdating = False
With ActiveSheet
    Master = .Name
    LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
    LastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
    .Range(.Cells(2, 1), .Cells(LastRow, LastCol)).Sort Key1:=.Cells(2, iCol), Order1:=xlAscending, _
        Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    iStart = 2
    For i = 2 To LastRow
        If .Cells(i, iCol).Value <> .Cells(i   1, iCol).Value Then
            iEnd = i
            Sheets.Add after:=Sheets(Sheets.Count)
            Set ws = ActiveSheet
            On Error Resume Next
            ws.Name = .Cells(iStart, iCol).Value
            On Error GoTo 0
            ws.Range(Cells(1, 1), Cells(1, LastCol)).Value = .Range(.Cells(1, 1), .Cells(1, LastCol)).Value
            .Range(.Cells(iStart, 1), .Cells(iEnd, LastCol)).Copy Destination:=ws.Range("A2")
            iStart = iEnd   1
        End If
    Next i
End With
Application.ScreenUpdating = True
End Sub

CodePudding user response：

Making a couple of assumptions about how this should work (eg. sheet naming)...

Sub Newly_Boarded()
    Const ROWS_PER_SHEET As Long = 4
    Const COL_ID As Long = 4
    Dim LastRow As Long, LastCol As Long, i As Long
    Dim ws As Worksheet, wsData As Worksheet, wb As Workbook
    Dim currId, n As Long, id, idSeq As Long
    
    Application.ScreenUpdating = False
    
    Set wb = ActiveWorkbook
    Set wsData = ActiveSheet
    
    With wsData
        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
        
        .Range(.Cells(2, 1), .Cells(LastRow, LastCol)).Sort Key1:=.Cells(2, COL_ID), Order1:=xlAscending, _
            Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
        
        currId = Chr(10)                   'any non-existing id...
        
        For i = 2 To LastRow
            id = .Cells(i, COL_ID).Value
            If id <> currId Or n = ROWS_PER_SHEET Then 'new id or reached ROWS_PER_SHEET limit?
                Set ws = wb.Sheets.Add(after:=wb.Sheets(wb.Sheets.Count))
                'copy headers
                ws.Cells(1, 1).Resize(1, LastCol).Value = .Cells(1, 1).Resize(1, LastCol).Value
                If id <> currId Then
                    idSeq = 1         'new id: reset sequence for sheet name suffix
                    currId = id
                Else
                    idSeq = idSeq   1 'same id: increment sequence for sheet name suffix
                End If
                ws.Name = currId & "_" & idSeq
                n = 0 'reset row count for this sheet
            End If
            
            n = n   1
            'copy this row
            ws.Range("A1").Offset(n).Resize(1, LastCol).Value = .Cells(i, 1).Resize(1, LastCol).Value
        Next i
    End With
    Application.ScreenUpdating = True
End Sub