循环遍历 50,000 多行并复制数据，直到第一列中的值发生变化

Question

我有一个 Excel 表，其中包含来自 A:N 的 50,000 多行数据。我有一个在 BackupData 工作表中有查询的主数据表。我目前复制该数据并作为值粘贴到备份工作表中。带有标题：

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

我正在尝试遍历所有这些行并复制单元格 A:N 的范围，直到 A 列中的第一个值发生变化，即第一个不同的 ID #。

然后我需要将所选范围粘贴到新工作簿中。

基本上，我想做与整合相反的事情。

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

Answer 1

试试

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