从不同工作簿中的多个工作表复制范围并保存

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