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

我定期將 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

uj5u.com熱心網友回復：

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

大量的作業簿

1. 代碼位于打開的作業簿 ( e.g. 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

uj5u.com熱心網友回復：

請測驗下一個代碼并發送一些反饋：

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\" 'build here your real path
    
    With Application 'some optimization to make the code faster:
        .ScreenUpdating = False: .EnableEvents = False
        .Calculation = xlCalculationManual
    End With
    For Each ws In wbBL.Worksheets  'iterate between all sheets of wbBL workbook
        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"                        'a string used to determine the columns of the following sliced array
            If i >= (lastRow - 1000) Then
                nrRows = lastRow - 1001     'calculate number of rows for the last slice on the sheet
            Else
               nrRows = 999
            End If
            'extract a slice array of all columns and 1000 (or rest up to the sheet end) rows:
            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 slice array content
            iCount = iCount   1              'increment the files count number
            Application.DisplayAlerts = False
             wbT.saveas savePath & saveName & iCount & ".xlsx" 'save the workbook (overwriting existing, if the case)
            Application.DisplayAlerts = True
            wbT.Close False                   'close the workbook without saving it
            i = i   nrRows                     'increment the rows interation variable
        Next i
    Next
    With Application
        .ScreenUpdating = True: .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With
    MsgBox "Ready..."
End Sub

標籤：

上一篇：VBA腳本從excel串列運行批處理檔案，讀取結果檔案，決議結果檔案并將結果寫入主excel檔案

下一篇：如何在VBA中使用vlookup？