VBA 将 N 行复制到每个筛选页面的新页面

Question

我是一个新的堆栈溢出用户所以如果有任何不正确的地方 post 请告诉我。

我有按公司 ID（第 4 列）过滤然后粘贴到新 sheet 的代码。我需要创建一个文本文件上传，每个 sheet 每个公司 ID 只能包含四个。是否可以使用 vba 将前四行过滤的行复制到新的 sheet，然后将接下来的四行复制到另一个 sheet，直到所有过滤的行都被复制，然后过滤下一个ID并复制到同一个新建作品sheets?

这是我目前正在使用的代码，它为每个公司 ID 过滤并创建一个新的 ws

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

Answer 1

对这应该如何工作做出一些假设（例如 sheet 命名）...

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

VBA 将 N 行复制到每个筛选页面的新页面

VBA to copy N rows to new page per filtered page

excel

vba

copy-paste

filter