Copy a Range from Multiple Sheets in a Different Workbook and Save-CodePudding

I regularly upload an excel file into an automated system. This system requires I use its "template" but I am limited to 1000 entries at a time. I frequently have 80k-100k entries to upload meaning I have to upload this template 80-100 times. I have managed to write a macro that splits my 80k-100k file into sheets containing 1000 enties each. What I have done up till now is then manually copy the range from each sheet into the "template", save the template with a unique name, and repeat until I copy all 80-100 sheets. I know there must be a faster way to loop through the sheets, copy to the "template", and save.

I have managed to get a loop started but it only copies the first sheet x number of times.

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

This is what I have been using to split the data

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

CodePudding user response：

Please, test the next code and send some feedback:

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

CodePudding user response：

Split by 1000 Records to New Workbooks

A Ton of Workbooks

The code is in an open workbook (e.g. Personal.xlsb).
Opens another file BigList.xlsx and prepares to copy a thousand rows at a time.
Opens another file Template.xlsx and pastes the rows.
Saves it as another file Name_?.xlsx. Closes Template.xlsx.
Repeats under 3 and 4 as needed.
Closes BigList.xlsx.

Carefully adjust the values in the constants section (especially the paths).

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