Offset VBA Copy From One to Multiple Worksheets-CodePudding

I am trying to copy from one worksheet named "List" to five worksheets named "First Upload", "Second Upload", "Third Upload", "Fourth Upload", and "Fifth Upload". I need to copy row 2 to "First Upload" row 3 to "Second Upload", row 4 to "Third Upload" etc. then loop through to the end of the worksheet (around 20,000 rows).

I am trying to end with roughly the same amount of rows on the multiple upload sheets and I need to separate them in this way due to requirements of the system I am using.

I am using the following code and it works for the first upload but brings too many results for the rest of the worksheets(ie double for the "Second Upload", triple for the "Third Upload". The code I am using is:

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

I thought that, in example, in the first part For X = 2 To LastRow Step 5 would start me at row 2 and offset 5 rows then For X = 3 To LastRow Step 5 would start me at row 3 and offset 5 rows but I think I was mistaken or I can't repeat the code like this. Any help with this would be greatly appreciated. Thank you

CodePudding user response：

FYI your problem is that you're not setting CopyRange to Nothing between each of the For X =... blocks, so you just keep accumulating rows instead of starting fresh.

You can do this with less code - and more flexibility with how many upload sheets you use - by using an array of ranges, and some minor renaming of your upload sheets:

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

CodePudding user response：

Split Data Into Multiple Worksheets

Adjust the source worksheet name (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
    
    ' Clear any filters.
    If sws.FilterMode Then sws.ShowAllData
    
    ' 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