從不同工作簿中的多個工作表復制范圍並保存

Question

我定期將 excel 文件上傳到自動化系統中。 這個系統需要我使用它的“模板”，但我一次只能輸入 1000 個條目。 我經常要上傳 80k-100k 條目，這意味着我必須上傳這個模板 80-100 次。 我設法編寫了一個宏，將我的 80k-100k 文件拆分為每張包含 1000 個實體的表格。 到目前為止，我所做的是將每張紙的范圍手動復制到“模板”中，用唯一的名稱保存模板，然后重復直到我復制所有 80-100 張紙。 我知道必須有一種更快的方法來遍歷工作表、復制到“模板”並保存。

我已經設法啟動了一個循環，但它只復制了第一張紙 x 次。

Sub CopytoTemp()
    Dim lngJ As Long
    Dim numSheets As Long
    Dim name As String
    Dim savePath As String
    Dim saveName As String
    lngJ = 0
    name = "Upload_"
    savePath = "Path\"
    saveName = "Name_"

'Counts the number of sheets in my big list
    numSheets = Workbooks("BigList.xlsx").Sheets.Count

'Loop through each sheet    
    While lngJ < numSheets
        Workbooks("BigList.xlsx").Worksheets(lngJ).Activate
        Range("A1:I1000").Select
        Selection.Copy
        Windows("Template.xlsx").Activate
'The first few columns are optional fields that I do not fill out        
        Range("E7").Select
        ActiveSheet.Paste
'Fills in the upload name field in the template
        Workbooks("Template.xlsx").Worksheets("Sheet1").Range("B2").Value = name & CStr(lngJ)
        wbICM.SaveAs (savePath & saveName & lngJ & ".xlsx")
        Workbooks.Open "Path\Template.xlsx"
        lngJ = lngJ + 1
    Wend

End Sub

這就是我用來分割數據的方法

Sub SplitWorksheet()
    Dim lngLastRow As Long
    Dim lngNumberOfRows As Long
    Dim lngI As Long
    Dim strMainSheetName As String
    Dim currSheet As Worksheet
    Dim prevSheet As Worksheet
    'Number of rows to split among worksheets
    lngNumberOfRows = 1000
    'Current worksheet in workbook
    Set prevSheet = ActiveWorkbook.ActiveSheet
    'First worksheet name
    strMainSheetName = prevSheet.Name
    'Number of rows in worksheet
    lngLastRow = prevSheet.Cells(Rows.count, 1).End(xlUp).Row
    'Worksheet counter for added worksheets
    lngI = 1
    While lngLastRow > lngNumberOfRows
        Set currSheet = ActiveWorkbook.Worksheets.Add
        With currSheet
           .Move after:=Worksheets(Worksheets.count)
           .Name = strMainSheetName + "(" + CStr(lngI) + ")"
        End With

        With prevSheet.Rows(lngNumberOfRows + 1 & ":" & lngLastRow).EntireRow
            .Cut currSheet.Range("A1")
        End With

        lngLastRow = currSheet.Cells(Rows.count, 1).End(xlUp).Row
        Set prevSheet = currSheet
        lngI = lngI + 1
    Wend
End Sub

Answer 1

請測試下一個代碼並發送一些反饋：

Sub CopytoTemp()
    Dim i As Long, name As String, savePath As String, saveName As String, lastRow As Long, arrC, arrSlice
    Dim wbBL As Workbook, ws As Worksheet, wbT As Workbook, nrRows As Long, iCount As Long, strCols As String
    
    Set wbBL = Workbooks("BigList.xlsx")

    name = "Upload_": saveName = "Name_"
    savePath = ThisWorkbook.Path & "\Path\" 'use here your real path
    
    For Each ws In wbBL.Worksheets
        lastRow = ws.Range("A" & ws.rows.Count).End(xlUp).row
        arrC = ws.Range("A1:I" & lastRow).Value  'place the whole range in an array
        For i = 1 To lastRow
            Set wbT = Workbooks.Open(savePath & "Template.xlsx") 'use here the Template full name
            strCols = "A:I"
            If i > (lastRow - 1000) Then
                nrRows = lastRow - 1000 'calculate number of rows for the last slice on the sheet
            Else
               nrRows = 999
            End If
            'create a slice array of all columns and 1000 (or rest up to the sheet end)
            arrSlice = Application.Index(arrC, Evaluate("row(" & i & ":" & i + nrRows & ")"), Evaluate("COLUMN(" & strCols & ")"))
            wbT.Worksheets("Sheet1").Range("A1").Resize(UBound(arrSlice), UBound(arrSlice, 2)).Value = arrSlice  'drop the array content
            iCount = iCount + 1        'create the files count number
            wbT.saveas savePath & saveName & iCount & ".xlsx"
            wbT.Close False
            i = i + nrRows             'increment i with already used number of rows
        Next i
    Next
End Sub

Answer 2

按 1000 條記錄拆分為新工作簿

大量的工作簿

1. 該代碼位於打開的工作簿中（ eg Personal.xlsb ）。
2. 打開另一個文件BigList.xlsx並准備一次復制一千行。
3. 打開另一個文件Template.xlsx並粘貼行。
4. 將其另存為另一個文件Name_?.xlsx 。 關閉Template.xlsx 。
5. 根據需要在 3 和 4 下重復。
6. 關閉BigList.xlsx 。

• 仔細調整常量部分中的值（尤其是路徑）。

Option Explicit

Sub CopytoTemp()
    
    ' Source
    Const swbPath As String = "C:\Test\2022\70701660\" ' ?
    Const swbName As String = "BigList.xlsx"
    Const swsID As Variant = 1 ' or "Sheet1" ?
    Const sfRow As Long = 1
    Const sCols As String = "A:I"
    Const sRows As Long = 1000
    ' Destination
    Const dPath As String = "C:\Test\2022\70701660\" ' ?
    Const dExtension As String = ".xlsx"
    Dim dFileFormat As XlFileFormat: dFileFormat = xlOpenXMLWorkbook
    Const dwbNameLeft As String = "Name_"
    Const dwsNameLeft As String = "Upload_"
    ' Template
    Const twbPath As String = "C:\Test\2022\70701660\" ' ?
    Const twbName As String = "Template.xlsx" ' usually .xltx ?
    Const twsName As String = "Sheet1"
    Const tfCellAddress As String = "E7"
    Const tnCellAddress As String = "B2"
    
    Application.ScreenUpdating = False
    
    Dim swb As Workbook: Set swb = Workbooks.Open(swbPath & swbName)
    Dim sws As Worksheet: Set sws = swb.Worksheets(swsID)
    Dim slCell As Range: Set slCell = sws.Columns(sCols) _
        .Find("*", , xlFormulas, , xlByRows, xlPrevious)
    Dim srCount As Long: srCount = slCell.Row - sfRow + 1
    Dim dCount As Long: dCount = Int(srCount / sRows)
    If srCount Mod sRows > 0 Then
        dCount = dCount + 1
    End If
    Dim sfrrg As Range: Set sfrrg = sws.Rows(sfRow).Columns(sCols)
    Dim cCount As Long: cCount = sfrrg.Columns.Count
    
    Dim twbFilePath As String: twbFilePath = twbPath & twbName
    
    Dim srg As Range
    
    Dim twb As Workbook
    Dim tws As Worksheet
    
    Dim d As Long
    Dim crCount As Long
    
    For d = 1 To dCount
        
        If srCount < sRows Then
            crCount = srCount
        Else
            crCount = sRows
            srCount = srCount - sRows
        End If
        
        Set srg = sfrrg.Resize(crCount)
        Set sfrrg = sfrrg.Offset(crCount) ' next
        
        Set twb = Workbooks.Open(twbFilePath)
        Set tws = twb.Worksheets(twsName)

        tws.Range(tfCellAddress).Resize(crCount, cCount).Value = srg.Value
        tws.Range(tnCellAddress).Value = dwsNameLeft & CStr(d)

        Application.DisplayAlerts = False ' overwrite without confirmation
        twb.SaveAs dPath & dwbNameLeft & CStr(d) & dExtension, dFileFormat
        Application.DisplayAlerts = True
        twb.Close SaveChanges:=False
    
    Next d
    
    swb.Close SaveChanges:=False
    
    Application.ScreenUpdating = True
    
    MsgBox "Done."

End Sub