excel - VBA 将 N 行复制到每个过滤页面的新页面

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

我有按公司 ID(第 4 列)的 filters 然后粘贴到新工作表的代码。我需要创建一个文本文件上传,每张表只能包含每个公司 ID 中的四个。是否可以使用 vba 将前四个过滤行复制到新工作表,然后将接下来的四行复制到另一个工作表,直到所有过滤行都被复制,然后 filter 用于下一个 ID 并复制到新创建的同一个工作表?

这是我目前使用的代码,它 filters 并为每个公司 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

回答1

对这应该如何工作做出一些假设(例如工作表命名)......

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

相似文章

最新文章