我有一個 Excel 作業表，其中包含來自 A:N 的 50,000 多行資料。我有一個主資料表，它在 BackupData 作業表中有一個查詢。我目前復制該資料并將其作為值粘貼到備份作業表中。帶有標題：
|ID|供應商#|名稱|客戶#|客戶|發票#|日期|專案#|專案描述|數量|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
enter code here
uj5u.com熱心網友回復：
嘗試
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
轉載請註明出處，本文鏈接：https://www.uj5u.com/net/345286.html
下一篇：在VBA中組合ForEach回圈