Offset VBA Copy From One to Multiple Worksheets - excel

Question

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

Answer 1

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
' 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

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