Macro to loop through 50,000 rows and copy data until value in the first column changes-CodePudding

I have an Excel sheet with 50,000 rows of data from A:N. I have a Master Data Sheet that has a query in the BackupData worksheet. I currently copy that data and paste as values into the Backup worksheet. With the headers:

|ID|Vendor #|Name|Customer #|Customer|Invoice #|Date|Item#|Item Description|Qty|B/C|Lbs|Amt|Amt#2|

I am trying to write a Macro that will loop through all of these rows and copy the range of cells A:N until the first value change in Column A, the first different ID #.

I then need to copy the selected range and paste into a new workbook. Basically, I want to do the opposite of consolidating. Here's the code I have so far. I appreciate any advice or suggestions!

    Sub inserting()
Dim wsBData, wsExport, wsCoverSht, wsBackup As Worksheet
Dim wbAllRebates, wbSingle As Workbook
    Set wbAllRebates = ActiveWorkbook
    Set wsBData = wbAllRebates.Sheets("BackupData")
    Set wsBackup = wbAllRebates.Sheets("Backup")
Dim rID, rTopRow As Range
Dim i As Long
Dim Counter As Integer
i = 3
Set rTopRow = Rows(1)
    Set rID = wsBackup.Range("A1")

wsBData.Cells.Copy
wsBackup.Cells.PasteSpecial Paste:=xlPasteValues

Counter = 0
LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row

Do
    If rID.Offset(i).Value <> rID.Offset(i - 1).Value Then
        Rows(rID.Offset(i).Row).Insert shift:=xlDown
        Call SubTotals(rID.Offset(i), rTopRow)
        i = i   1
        Set rTopRow = Rows(rID.Offset(i).Row)
                
    End If
Exit Do
Loop


MsgBox i

End Sub

Sub SubTotals(rID As Range, firstRow As Range)
rID.Value = "Total"
rID.Offset(, 9).Value = Application.WorksheetFunction.Sum(Range(firstRow.Cells(1, 10).Address & ":" & rID.Offset(-1, 1).Address))
End Sub
enter code here

CodePudding user response：

Try

Option Explicit

Sub SeparateWB()

    Dim wsBData As Worksheet, wsBackup As Worksheet, wb As Workbook
    Dim wbAllRebates As Workbook, rngHeader As Range
    Dim i As Long, n As Long, LastRow As Long, StartRow As Long
       
    Set wbAllRebates = ActiveWorkbook
    With wbAllRebates
        Set wsBData = .Sheets("BackupData")
        Set wsBackup = .Sheets("Backup")
    End With
    
    wsBData.Cells.Copy
    wsBackup.Cells.PasteSpecial Paste:=xlPasteValues
    
    StartRow = 2
    Application.ScreenUpdating = False
    With wsBackup
        LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
        Set rngHeader = .Range("A1:N1")
        For i = 2 To LastRow
           ' change ID next row
           If .Cells(i, "A") <> .Cells(i   1, "A") Then
               ' create new workbook
               Set wb = Workbooks.Add(1)
               rngHeader.Copy wb.Sheets(1).Range("A1")
               .Range("A" & StartRow & ":N" & i).Copy wb.Sheets(1).Range("A2")
               wb.SaveAs .Cells(i, "A") & ".xlsx"
               wb.Close False
               ' move to next
               StartRow = i   1
               n = n   1
           End If
        Next
    End With
    Application.ScreenUpdating = True
    MsgBox n & " workbooks created"
End Sub