VBA Copy from one worksheet to several

[aflynn]

Hello, and thanks in advance for any help.

I have a giant list of social security numbers, about 30,000 rows. I use a function to get the first five digits of the social security number in Column D. I can't have more then 4 rows with the first five digits on the same sheet. Currently I run the code below that sorts the list then separates the five digit code to new worksheets with four rows per worksheet and names them sequentially ie 10660_1, 10660_2, 10660_3 etc.


Sub Stack()

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.Resize(1, LastCol).Value = .Cells(i, 1).Resize(1, LastCol).Value
Next i
End With
Application.ScreenUpdating = True
End Sub


I then run a second code, below, to compile these tabs onto five separate sheets based on the suffix ie 10660_1 is copied to a worksheet named First Upload, 10660_2 is copied to a worksheet named Second upload. I have five of these worksheets (First Upload - Fifth Upload) and that is enough, I usually have less then 16 of the same first five digits.

Sub Stack2()
Dim Sheet As Worksheet
Dim TargetRow As Long


Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False

TargetRow = 1
For Each Sheet In ActiveWorkbook.Sheets
If Sheet.Name Like "*" & strSearch & "_1" Then
Sheets(Sheet.Name).Range("A2:E5").Copy
With ThisWorkbook.Sheets("First Upload").Cells(TargetRow, 1)
.PasteSpecial Paste:=xlPasteValues
.PasteSpecial Paste:=xlPasteFormats
End With
TargetRow = TargetRow + 4
End If
Next
Application.CutCopyMode = False
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

TargetRow = 1
For Each Sheet In ActiveWorkbook.Sheets
If Sheet.Name Like "*" & strSearch & "_2" Then
Sheets(Sheet.Name).Range("A2:E5").Copy
With ThisWorkbook.Sheets("Second Upload").Cells(TargetRow, 1)
.PasteSpecial Paste:=xlPasteValues
.PasteSpecial Paste:=xlPasteFormats
End With
TargetRow = TargetRow + 4
End If
Next
Application.CutCopyMode = False
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic


TargetRow = 1
For Each Sheet In ActiveWorkbook.Sheets
If Sheet.Name Like "*" & strSearch & "_3" Then
Sheets(Sheet.Name).Range("A2:E5").Copy
With ThisWorkbook.Sheets("Third Upload").Cells(TargetRow, 1)
.PasteSpecial Paste:=xlPasteValues
.PasteSpecial Paste:=xlPasteFormats
End With
TargetRow = TargetRow + 4
End If
Next
Application.CutCopyMode = False
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic


TargetRow = 1
For Each Sheet In ActiveWorkbook.Sheets
If Sheet.Name Like "*" & strSearch & "_4" Then
Sheets(Sheet.Name).Range("A2:E5").Copy
With ThisWorkbook.Sheets("Fourth Upload").Cells(TargetRow, 1)
.PasteSpecial Paste:=xlPasteValues
.PasteSpecial Paste:=xlPasteFormats
End With
TargetRow = TargetRow + 4
End If
Next
Application.CutCopyMode = False
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic


TargetRow = 1
For Each Sheet In ActiveWorkbook.Sheets
If Sheet.Name Like "*" & strSearch & "_5" Then
Sheets(Sheet.Name).Range("A2:E5").Copy
With ThisWorkbook.Sheets("Fifth Upload").Cells(TargetRow, 1)
.PasteSpecial Paste:=xlPasteValues
.PasteSpecial Paste:=xlPasteFormats
End With
TargetRow = TargetRow + 4
End If
Next
Application.CutCopyMode = False
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub


This takes a very long time, usually 1.5 hours and excel freezes.

Is there a better way to do this? I have been thinking that simply sorting based on the five digit number in Column D, then copying the first four rows to the First Upload tab, the second four rows to the Second Upload tab etc then after Fifth upload looping back to the First Upload tab and pasting below the data in that tab would result with unique first five digit numbers per tab. I have been trying to use offset to accomplish this but I am getting lost on how to utilize it.

Sorry for the long post. Any help with this would be greatly appreciated. Thank you.

 

[DanteAmor]

Is there a better way to do this? I have been thinking that simply sorting based on the five digit number in Column D, then copying the first four rows to the First Upload tab, the second four rows to the Second Upload tab etc then after Fifth upload looping back to the First Upload tab and pasting below the data in that tab would result with unique first five digit numbers per tab.

I suppose that in the first macro, you create the sheets to store the data temporarily, to finally pass the data to the "upload" sheets.

With the following code, instead of storing the data in temporary sheets, it uses arrays to store the data in memory.
So the following code does not create the sheets "Id_idSeq", it only passes the data to the "upload" sheets, which is the end goal.

Change the name "Raw" in the macro to the name of your main sheet.

Set sh = Sheets("Raw")

Copy all the following code. I test with 30,000 rows, the result is immediate.

Option Explicit

Dim b1 As Variant, b2 As Variant, b3 As Variant, b4 As Variant, b5 As Variant
Dim k1 As Long, k2 As Long, k3 As Long, k4 As Long, k5 As Long

Sub Stack_Copy()
  Dim a As Variant
  Dim rng As Range
  Dim sh As Worksheet
  Dim arr As Variant, ky As Variant, ant As Variant
  Dim i As Long, j As Long, lr As Long, lc As Long, m As Long, n As Long
   
  Set sh = Sheets("Raw")
  lr = sh.Range("D" & Rows.Count).End(3).Row
  lc = sh.Cells(1, Columns.Count).End(1).Column
  Set rng = sh.Range("A2", sh.Cells(lr, lc))
  rng.Sort sh.Range("D2"), xlAscending, Header:=xlYes
  a = rng.Value
  
  ReDim b1(1 To UBound(a, 1), 1 To UBound(a, 2))
  ReDim b2(1 To UBound(a, 1), 1 To UBound(a, 2))
  ReDim b3(1 To UBound(a, 1), 1 To UBound(a, 2))
  ReDim b4(1 To UBound(a, 1), 1 To UBound(a, 2))
  ReDim b5(1 To UBound(a, 1), 1 To UBound(a, 2))
  k1 = 0: k2 = 0: k3 = 0: k4 = 0: k5 = 0
  
  For i = 1 To UBound(a, 1)
    'get the first five digits of the social security number
    If ant <> Left(a(i, 4), 5) Or m > 4 Then
      If ant <> Left(a(i, 4), 5) Then n = 1 Else n = n + 1
      m = 1
    End If
    Select Case n
      Case 1: Call arrcount(k1, a, i, b1)
      Case 2: Call arrcount(k2, a, i, b2)
      Case 3: Call arrcount(k3, a, i, b3)
      Case 4: Call arrcount(k4, a, i, b4)
      Case 5: Call arrcount(k5, a, i, b5)
    End Select
    ant = Left(a(i, 4), 5)                    'get the first five digits of the social security number
    m = m + 1
  Next
  
  arr = Array("First Upload", k1, b1, "Second Upload", k2, b2, "Third Upload", k3, b3, _
              "Fourth Upload", k4, b4, "Fifth Upload", k5, b5)
  For i = 0 To UBound(arr) Step 3
    Sheets(arr(i)).Cells.ClearContents
    If arr(i + 1) > 0 Then Sheets(arr(i)).Range("A1").Resize(arr(i + 1), UBound(b1, 2)).Value = arr(i + 2)
  Next
End Sub

Sub arrcount(kn As Long, a As Variant, i As Long, bn As Variant)
  Dim j As Long
  kn = kn + 1
  For j = 1 To UBound(a, 2)
    bn(kn, j) = a(i, j)
  Next
End Sub