How to Efficient way for create Multiple Workbooks

[Guna13]

Hi Team,

We have a requirement to create multiple workbooks containing one-line questions and answers to share with our internal supplier team. We are looking for a fast and efficient way to generate these workbooks. Can anyone provide guidance or suggest techniques to streamline this process? (For my requirement i need to create more than 1500+ Files )

Sub CreateWorkbooksForEachFilter()
Dim startTime As Double, endTime As Double
Dim durationSeconds As Double, durationHours As Integer, durationMinutes As Integer, durationSecondsLeft As Integer
Dim durationString As String

' Record the start time
startTime = Timer

Dim wbSource As Workbook, wbNew As Workbook
Dim wsTemplate As Worksheet, wsValidation As Worksheet, wsBPCode As Worksheet
Dim filterValue As Range, uniqueValues As Range
Dim lastRow As Long, newRow As Long

' Disable screen updating and calculation to improve performance
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False

' Set the source workbook
Set wbSource = ThisWorkbook

Set wsTemplate = wbSource.Sheets("Template")
Set wsValidation = wbSource.Sheets("Validation")

If wsTemplate.AutoFilterMode Then wsTemplate.AutoFilterMode = False
If wsValidation.AutoFilterMode Then wsValidation.AutoFilterMode = False

' Define the range of unique values in column C of the Validation sheet
Set uniqueValues = wsValidation.Range("C2:C" & wsValidation.Cells(wsValidation.Rows.Count, "C").End(xlUp).Row).SpecialCells(xlCellTypeConstants)

' Loop through each unique value in column C of the Validation sheet
For Each filterValue In uniqueValues
' Filter the Template sheet based on the current value
wsTemplate.Range("A5:AX5").AutoFilter Field:=1, Criteria1:=filterValue.Value

' Find the last row of filtered data
lastRow = wsTemplate.Cells(wsTemplate.Rows.Count, "A").End(xlUp).Row
' Get the value from column E of the last row
Dim eValue As Variant
eValue = wsTemplate.Cells(lastRow, "E").Value
emailAdr = wsTemplate.Cells(lastRow, "M").Value

' Check if there is data to copy
If lastRow > 5 Then ' Assuming data starts from row 3
' Create a new workbook
Set wbNew = Workbooks.Add

Set wsBPCode = wbNew.Sheets(1)
wsBPCode.Name = filterValue.Value

wsTemplate.Range("A1:AC" & lastRow).Copy Destination:=wsBPCode.Cells(1, 1)

For Each ws In wbSource.Sheets
If ws.Name <> "Template" And ws.Name <> "Validation" Then
' Copy the sheet to the new workbook
ws.Copy After:=wbNew.Sheets(wbNew.Sheets.Count)

' Activate the copied sheet
Set wsCopied = wbNew.Sheets(wbNew.Sheets.Count)
wsCopied.Activate

' Remove gridlines and autofit columns
ActiveWindow.DisplayGridlines = False
wsCopied.Columns.AutoFit
End If
Next ws

fileName = filterValue.Value & "-" & eValue & ".xlsx"
wbNew.SaveAs "C:\Test\E-Invoice\" & fileName
wbNew.Close False ' Close the workbook without saving changes

wsValidation.Cells(filterValue.Row, "E").Value = "C:\Test\E-Invoice\" & fileName
wsValidation.Cells(filterValue.Row, "F").Value = emailAdr
End If

wsTemplate.AutoFilterMode = False

DoEvents
Next filterValue

endTime = Timer

durationSeconds = endTime - startTime

durationHours = Int(durationSeconds / 3600)
durationSecondsLeft = durationSeconds Mod 3600
durationMinutes = Int(durationSecondsLeft / 60)
durationSecondsLeft = durationSecondsLeft Mod 60

durationString = Format(durationHours, "00") & ":" & Format(durationMinutes, "00") & ":" & Format(durationSecondsLeft, "00")

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

MsgBox "Workbooks created successfully." & vbCrLf & _
"Total Duration: " & durationString, vbInformation
End Sub

 

[Guna13]

How to create 1000+ Workbook, based on Cell value. even i have 1000 Records in Macro Sheet. how to create this workbook?