VBA Code to Create Workbooks from Template file

[Mushtaq86]

Dear All,

Greetings of the Day !!!

I need a VBA to create "n" workbooks with some rules.
Workbook are template files to be read from fixed location (say template folder in "C-drive, C:\Excel Templates")
"n" is the count of list in the active workbook and names of the workbook is the range of the same list.

Hope i am bit clear and not very greedy.

If needed i can attach the working file and the template files.

Many Thanks in advance.

Cheers !!!

 

[BrianJN1]

To see the files would be a good start.

 

[Mushtaq86]

Sure Sir.
Will upload the files in a while.

 

[Mushtaq86]

I am sorry... the link to upload the attachment is missing.
Can anyone guide me to activate that, PLEASE !!!

 

[BrianJN1]

If you don't have something like "Dropbox" you could try something from the selection offered here.

 

[Mushtaq86]

Dear All,

I somehow was able to create the desired VBA, with the help of some past posts of other users & some help from other forums. Thanks to all of them.
The requirement was to create the workbooks from a Template file with pasting some project information in the template file.
Below is the VBA

Sub Create_Workbooks()
    Dim CalcMode As Long
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim WSNew As Worksheet
    Dim rng As Range
    Dim cell As Range
    Dim Lrow As Long
    Dim foldername As String
    Dim MyPath As String
    Dim FieldNum As Integer
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    
    'Name of the sheet with your data
    Set ws1 = Sheets("Summary") '<<< Change
    
'Copying the Project information in the template file
    Range("C2:C7").Select
    Selection.Copy
    Workbooks.Open Filename:="C:\Excel Templates\Reinf. for Walls.xlsm"
    Range("C2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("I12").Select
    Application.CutCopyMode = False
    ActiveWorkbook.SaveAs Filename:= _
        "C:\Excel Templates\Reinf. for Walls - Temp.xlsm", FileFormat:= _
        xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
    ActiveWorkbook.Save
    ActiveWorkbook.Close
    Range("D10").Select
  
     'Determine the Excel version and file extension/format
    If Val(Application.Version) < 12 Then
         'You use Excel 97-2003
        FileExtStr = ".xls": FileFormatNum = -4143
    Else
         'You use Excel 2007
        If ws1.Parent.FileFormat = 56 Then
            FileExtStr = ".xls": FileFormatNum = 56
        Else
            FileExtStr = ".xlsm": FileFormatNum = 52
        End If
    End If
    
     'Set filter range : A1 is the top left cell of your filter range and
     'the header of the first column, D is the last column in the filter range
      Set rng = ws1.Range("B9:AB" & Rows.Count)
    
     'Set Field number of the filter column
     'This example filters on the first field in the range(change the field if needed)
    FieldNum = 2
    
    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With
    
     ' Add worksheet to copy/Paste the unique list
    Set ws2 = Worksheets.Add
    
     'Fill in the path\folder where you want the new folder with the files
     'you can use also this "C:\Users\Ron\test"
    MyPath = "C:\"
    
     'Add a slash at the end if the user forget it
    If Right(MyPath, 1) <> "\" Then
        MyPath = MyPath & "\"
    End If
    
     'Create folder for the new files
    foldername = "C:\All Files at " & Format(Now, "yyyy-mm-dd hh-mm-ss") & "\"
    MkDir foldername
    
    With ws2
         'first we copy the Unique data from the filter field to ws2
        rng.Columns(FieldNum).AdvancedFilter _
        Action:=xlFilterCopy, _
        CopyToRange:=.Range("A1"), Unique:=True
        
         'loop through the unique list in ws2 and filter/copy to a new workbook
        Lrow = .Cells(Rows.Count, "A").End(xlUp).Row
        For Each cell In .Range("A2:A" & Lrow)
            
             'Add new workbook with one sheet
            'Set WSNew = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
            Workbooks.Open ("C:\Excel Templates\Reinf. for Walls - Temp.xlsm")
            Set WSNew = ActiveWorkbook.Worksheets(1)
            
             'Firstly, remove the AutoFilter
            ws1.AutoFilterMode = False
            
             'Filter the range
            rng.AutoFilter Field:=FieldNum, Criteria1:="=" & cell.Value
          
             '
           'Save the file in the new folder and close it
            WSNew.Parent.SaveAs foldername & cell.Value & FileExtStr, FileFormatNum
            WSNew.Parent.Close False
            
             'Close AutoFilter
            ws1.AutoFilterMode = False
            
        Next cell
        
         'Delete the ws2 sheet
        On Error Resume Next
        Application.DisplayAlerts = False
        .Delete
        Application.DisplayAlerts = True
        On Error GoTo 0
        
    End With
    
    MsgBox "Look in " & foldername & " for the files"
    
    With Application
        .ScreenUpdating = True
        .Calculation = CalcMode
    End With
End Sub

@BrianJN1: Thanks for your interest and response.

Wish you all loads of success and great day ahead.
Cheers !!!