偏移 VBA 从一个工作表复制到多个工作表

Question

我正在尝试从一个名为“列表”的工作表复制到名为“第一次上传”、“第二次上传”、“第三次上传”、“第四次上传”和“第五次上传”的五个工作表。我需要将第 2 行复制到“第一次上传”，第 3 行复制到“第二次上传”，第 4 行复制到“第三次上传”等，然后循环到工作表的末尾（大约 20,000 行）。

我试图在多个上传表上以大致相同的行数结束，并且由于我正在使用的系统的要求，我需要以这种方式将它们分开。

我正在使用以下代码，它适用于第一次上传，但为其余工作表带来了太多结果（即“第二次上传”的两倍，“第三次上传”的三倍）。我使用的代码是：

Sub OffsetTrial()
    
    Dim X As Long, LastRow As Long
    Dim CopyRange As Range
    LastRow = Cells(Cells.Rows.Count, "A").End(xlUp).Row
    For X = 2 To LastRow Step 5
        If CopyRange Is Nothing Then
            Set CopyRange = Rows(X).EntireRow
        Else
            Set CopyRange = Union(CopyRange, Rows(X).EntireRow)
        End If
    Next
    If Not CopyRange Is Nothing Then
    CopyRange.Copy Destination:=Sheets("First Upload").Range("A2")
    End If
    
    LastRow = Cells(Cells.Rows.Count, "A").End(xlUp).Row
    For X = 3 To LastRow Step 5
        If CopyRange Is Nothing Then
            Set CopyRange = Rows(X).EntireRow
        Else
            Set CopyRange = Union(CopyRange, Rows(X).EntireRow)
        End If
    Next
    If Not CopyRange Is Nothing Then
    CopyRange.Copy Destination:=Sheets("Second Upload").Range("A2")
    End If
    
    LastRow = Cells(Cells.Rows.Count, "A").End(xlUp).Row
    For X = 4 To LastRow Step 5
        If CopyRange Is Nothing Then
            Set CopyRange = Rows(X).EntireRow
        Else
            Set CopyRange = Union(CopyRange, Rows(X).EntireRow)
        End If
    Next
    If Not CopyRange Is Nothing Then
    CopyRange.Copy Destination:=Sheets("Third Upload").Range("A2")
    End If
    
    LastRow = Cells(Cells.Rows.Count, "A").End(xlUp).Row
    For X = 5 To LastRow Step 5
        If CopyRange Is Nothing Then
            Set CopyRange = Rows(X).EntireRow
        Else
            Set CopyRange = Union(CopyRange, Rows(X).EntireRow)
        End If
    Next
    If Not CopyRange Is Nothing Then
    CopyRange.Copy Destination:=Sheets("Fourth Upload").Range("A2")
    End If
    
    LastRow = Cells(Cells.Rows.Count, "A").End(xlUp).Row
    For X = 6 To LastRow Step 5
        If CopyRange Is Nothing Then
            Set CopyRange = Rows(X).EntireRow
        Else
            Set CopyRange = Union(CopyRange, Rows(X).EntireRow)
        End If
    Next
    If Not CopyRange Is Nothing Then
    CopyRange.Copy Destination:=Sheets("Fifth Upload").Range("A2")
    End If
    
End Sub

我认为，例如，在第一部分中，For X = 2 To LastRow Step 5 将从第 2 行开始并偏移 5 行，然后 For X = 3 To LastRow Step 5 将从第 3 行开始并偏移 5 行，但我认为我错了或者我不能重复像这样的代码。对此的任何帮助将不胜感激。谢谢

Answer 1

将数据拆分为多个工作表

• 调整源工作表名称 (sName)。

Sub SplitUploads()
    
    ' Define constants.
    ' Source
    Const sName As String = "Sheet1"
    ' Destination
    Dim dwsLefts() As Variant
    dwsLefts = VBA.Array("First", "Second", "Third", "Fourth", "Fifth")
    Const dwsRight As String = " Upload"
    Const dFirstCellAddress As String = "A2"
    
    ' Reference the workbook ('wb').
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Reference the source worksheet ('sws').
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    
    Application.ScreenUpdating = False
    
    ' Turn off AutoFilter.
    If sws.AutoFilterMode Then sws.AutoFilterMode = False
    
    ' Reference the source (table) range ('srg') (has headers).
    Dim srg As Range: Set srg = sws.Range("A1").CurrentRegion
    
    ' Write the source number of rows and columns
    ' to variables ('srCount','scCount').
    Dim srCount As Long: srCount = srg.Rows.Count
    Dim scCount As Long: scCount = srg.Columns.Count
    
    ' Reference the source data range ('sdrg') (no headers).
    Dim sdrg As Range: Set sdrg = srg.Resize(srCount - 1).Offset(1)
    
    ' Reference the source integer sequence data range ('sidrg') (no headers).
    Dim sidrg As Range: Set sidrg = sdrg.Resize(, 1).Offset(, scCount)
    ' Fill the source integer sequence range with an ascending integer sequence.
    sidrg.Value = sws.Evaluate("ROW(1:" & srCount - 1 & ")")
    
    ' Write the upper limit of the lefts array
    ' (destination worksheets left names) to a variable ('cUpper').
    Dim cUpper As Long: cUpper = UBound(dwsLefts)
    
    ' Reference the source groups sequence data range ('sgdrg') (no headers).
    Dim sgdrg As Range: Set sgdrg = sidrg.Offset(, 1)
    ' Fill the groups sequence range with the groups sequence.
    sgdrg.Value = sws.Evaluate("MOD(" & sidrg.Address(0, 0) & "-1," _
        & CStr(cUpper + 1) & ")+1")
    
    ' Reference the source expanded range ('serg'), the source range
    ' including the two additional columns (has headers).
    Dim serg As Range: Set serg = srg.Resize(, scCount + 2)
    
    ' Sort the source expanded range ascending by the groups sequence column
    ' so when the range is being filtered, there is only one area.
    serg.Sort serg.Columns(scCount + 2), xlAscending, , , , , , xlYes
    
    Dim dws As Worksheet
    Dim dfCell As Range
    Dim sfrg As Range
    Dim c As Long
    
    ' Loop through the elements of the lefts array.
    For c = 0 To cUpper
        
        ' Reference the current destination worksheet ('dws').
        Set dws = wb.Worksheets(dwsLefts(c) & dwsRight)
        ' Reference the destination first cell.
        Set dfCell = dws.Range(dFirstCellAddress)
        ' Clear previous data.
        dfCell.Resize(dws.Rows.Count - dfCell.Row + 1, _
            dws.Columns.Count - dfCell.Column + 1).Clear
        
        ' Filter the expanded range by the current group ('c + 1').
        serg.AutoFilter scCount + 2, c + 1
        
        ' Attempt to reference the source filtered range ('sfrg')
        ' (additional columns not included) (no headers).
        On Error Resume Next
            Set sfrg = sdrg.SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
        
        ' Turn off the autofilter.
        sws.AutoFilterMode = False
        
        ' Copy.
        If Not sfrg Is Nothing Then ' filtered data is present
            ' Copy the source filtered range to the destination worksheet.
            sfrg.Copy Destination:=dfCell
            Set sfrg = Nothing ' reset the source filtered range variable
        'Else ' no filtered data; do nothing
        End If
                
    Next c
    
    ' Sort the source expanded range ascending by the integer sequence column
    ' so the data gets back to its original rows.
    serg.Sort serg.Columns(scCount + 1), xlAscending, , , , , , xlYes
    
    ' Clear the additional columns.
    Union(sidrg, sgdrg).ClearContents
    
    ' Save the workbook.
    'wb.Save
    
    Application.ScreenUpdating = True
    
    ' Inform.
    MsgBox "Uploads split.", vbInformation
    
End Sub

Answer 2

仅供参考，您的问题是您没有在每个 For X =... 块之间将 CopyRange 设置为 Nothing，因此您只是继续累积行而不是重新开始。

您可以用更少的代码来做到这一点——并且可以更灵活地使用多少个上传表——通过使用一系列范围，并对您的上传表进行一些小的重命名：

Sub OffsetTrial()
    Const NUM_SHEETS As Long = 3
    Const START_ROW As Long = 2
    
    Dim X As Long, ws As Worksheet
    Dim ranges(1 To NUM_SHEETS) As Range, shtNum As Long
    
    Set ws = ActiveSheet 'or some specific sheet...
    
    For X = START_ROW To ws.Cells(ws.Cells.Rows.Count, "A").End(xlUp).Row
        shtNum = 1 + ((X - START_ROW) Mod NUM_SHEETS) 'which destination sheet?
        BuildRange ranges(shtNum), ws.Rows(X)
    Next
    
    For X = 1 To NUM_SHEETS
        If Not ranges(X) Is Nothing Then
            ranges(X).Copy Sheets("Upload " & X).Range("A2")
        End If
    Next X
    
End Sub

Sub BuildRange(rngTot As Range, rngToAdd As Range)
    If rngTot Is Nothing Then
        Set rngTot = rngToAdd
    Else
        Set rngTot = Application.Union(rngTot, rngToAdd)
    End If
End Sub