VBA code needed to create multiple individual workbooks using template and table of data

andyporter1975

New Member
Joined
Feb 3, 2014
Messages
27
Hello,

If anyone can help me with VBA code for the following it would be greatly appreciated.

I have a table of data which contains multiple rows and columns. Each row relates to a unique business and each column contains data relating to that business.

Using a pre-defined excel doc as a template, I want to be able to automatically populate this template with the info for one businesses into a specific row on the template, save it as the name given in one of the cells into a local folder and then do the same for each and every row within the original table of data.

Is this possible??

Thank you in advance for any hep suggested.
 

Hyakkivn

New Member
Joined
Jul 28, 2021
Messages
44
Office Version
  1. 2010
Platform
  1. Windows
1st. What does your "Demo table data" look like? And does it have same shape with template or not ?
2nd. Are your template and your Store data in the same workbook or they are separated? (you save store data to new workbook)
I will pretend that your Demo table Data is the same shape with your template, and the Store sheet is in the same file with Template file.
Here the code. It works for me
VBA Code:
Sub whatEverNameYouWant()
Dim tPlate As Workbook ' template macro
Dim wrkngFile As Workbook
Dim tPath As String, tFile As String ' template path location and template file
Application.ScreenUpdating = False

tPath = "F:\Documents"  'change this to fit your situation (e.g: D:\Foldername\Folder1name
tFile = tPath & "\Template.xlsx"

Set wrkngFile = ActiveWorkbook
wrkngFile.Range("A4:I4").Select  'or Row("4:4").Select
Selection.Copy
' Open template file and save name as variable
Set tPlate = Workbooks.Open(tFile)
Sheets("Template").Select
Range("A4").Select
Selection.PasteSpecial xlPasteValues
Application.CutCopyMode = False
Sheets("Template").Select
Sheets("Template").Copy After:=Sheets(1)
ActiveSheet.Name = Sheets(1).Range("A4")
End Sub
 

Excel Facts

How to calculate loan payments in Excel?
Use the PMT function: =PMT(5%/12,60,-25000) is for a $25,000 loan, 5% annual interest, 60 month loan.

Hyakkivn

New Member
Joined
Jul 28, 2021
Messages
44
Office Version
  1. 2010
Platform
  1. Windows
@*Sacha04Cat: I think your template is also your working-book. You just want it to be saved somewhere with Name = customer's code in J3. Am I right?
 

Sacha04Cat

New Member
Joined
Sep 7, 2021
Messages
7
Office Version
  1. 365
Platform
  1. Windows
Sorry for the delay, As you can see in my previous table formulas, the sheet vlookup to the tables (hided) in the same workbook
1631189758533.png


The sheet is kind of a order form, the customer enter their quantity of the product they want. so we need to keep the formula for price extention, total etc.
So the steps could be
1- Copy the first customer account from the table CUST9,Customer account (Customer Save as tab) and copy in sheet.J3 (The vlookup update the info)
2- Save the file in folder X with the name format in sheet.E2 [Cell=CONCAT(MID(J8,6,3),"-",C5,"-",C6)]
3- Leave always the template open
4- select the next customer code from the table CUST9,Customer account (Customer Save as tab) and copy in sheet.J3 (The vlookup update the info)
5-Repeat 2@4 until the end of the customers list

Thank you

Sacha
 

Zot

Well-known Member
Joined
Nov 26, 2020
Messages
1,883
Office Version
  1. 2016
Platform
  1. Windows
Sorry for late reply. I was so busy and only have a chance to work on it today

A data workbook will have 2 sheets. One is for data (Sheet1) and the other is Template. You can hide the template if you want.

Once you run the macro, it will ask for folder where you save all your file. If the filename is not existed yet it will create one and save the data. You just need to clear old data in data sheet and copy new one and run again. It will keep adding to existing files.

Hope this is what you wanted
VBA Code:
Sub CompileData()

Dim nNext As Long
Dim FPath As String, wbName As String
Dim cell As Range, rngData As Range
Dim ws As Worksheet, wsData As Worksheet, wsTmp As Worksheet
Dim wb As Workbook, wbData As Workbook
Dim dWB As Object

Set wbData = ActiveWorkbook
Set wsData = wbData.Sheets("Sheet1")
Set wsTmp = wbData.Sheets("Template")
Set dWB = CreateObject("Scripting.Dictionary")

Set rngData = wsData.Range("A4", wsData.Cells(Rows.Count, "A").End(xlUp))

Application.ScreenUpdating = False

Open_All_WB_in_Folder FPath
Register_All_Open_WB dWB

For Each cell In rngData
    wbName = cell & ".xlsx"
    If Not dWB.Exists(wbName) Then
        NewWorkbook FPath, cell, 1
        dWB.Add wbName, Nothing
        Set wb = Workbooks(wbName)
        Set ws = wb.Sheets("Sheet1")
        wsTmp.Cells.Copy ws.Range("A1")
    Else
        Set wb = Workbooks(wbName)
        Set ws = wb.Sheets("Sheet1")
    End If
    nNext = ws.Cells(Rows.Count, "A").End(xlUp).Offset(1).Row
    If nNext = 1 Then nNext = 4
    wsData.Range("A" & cell.Row, "I" & cell.Row).Copy ws.Range("A" & nNext)
Next

Save_And_Close_All_WB wbData, FPath

End Sub

Sub Register_All_Open_WB(dict As Object)

Dim wb As Workbook
Dim wbName As String

Set dict = CreateObject("Scripting.Dictionary")

'Loop through all workbooks
For Each wb In Application.Workbooks
    dict.Add wb.Name, Nothing
Next

End Sub

Sub Open_All_WB_in_Folder(FPath As String)

Dim DialogBox As FileDialog
Dim FileOpen As String

On Error Resume Next
Set DialogBox = Application.FileDialog(msoFileDialogFolderPicker)
If DialogBox.Show = -1 Then
    FPath = DialogBox.SelectedItems(1)
End If
If FPath = "" Then Exit Sub
FileOpen = Dir(FPath & "\*.xlsx*")

Do While FileOpen <> ""
    Workbooks.Open FPath & "\" & FileOpen
    FileOpen = Dir
Loop

End Sub

Sub Save_And_Close_All_WB(wbData As Workbook, FPath As String)

Dim wb As Workbook

For Each wb In Application.Workbooks
    If Not wb.Name = wbData.Name Then
        wb.Close SaveChanges:=True
    End If
Next

End Sub


Function NewWorkbook(ByVal wbPath As String, ByVal wbName As String, ByVal wsCount As Integer) As Workbook

Dim OriginalWorksheetCount As Long
Dim NewName As String

Set NewWorkbook = Nothing
If wsCount < 1 Or wsCount > 255 Then Exit Function
OriginalWorksheetCount = Application.SheetsInNewWorkbook
Application.SheetsInNewWorkbook = wsCount
Set NewWorkbook = Workbooks.Add
NewName = wbPath & "\" & wbName
ActiveWorkbook.SaveAs NewName
Application.SheetsInNewWorkbook = OriginalWorksheetCount

End Function
 

Sacha04Cat

New Member
Joined
Sep 7, 2021
Messages
7
Office Version
  1. 365
Platform
  1. Windows
Sorry for late reply. I was so busy and only have a chance to work on it today

A data workbook will have 2 sheets. One is for data (Sheet1) and the other is Template. You can hide the template if you want.

Once you run the macro, it will ask for folder where you save all your file. If the filename is not existed yet it will create one and save the data. You just need to clear old data in data sheet and copy new one and run again. It will keep adding to existing files.

Hope this is what you wanted
VBA Code:
Sub CompileData()

Dim nNext As Long
Dim FPath As String, wbName As String
Dim cell As Range, rngData As Range
Dim ws As Worksheet, wsData As Worksheet, wsTmp As Worksheet
Dim wb As Workbook, wbData As Workbook
Dim dWB As Object

Set wbData = ActiveWorkbook
Set wsData = wbData.Sheets("Sheet1")
Set wsTmp = wbData.Sheets("Template")
Set dWB = CreateObject("Scripting.Dictionary")

Set rngData = wsData.Range("A4", wsData.Cells(Rows.Count, "A").End(xlUp))

Application.ScreenUpdating = False

Open_All_WB_in_Folder FPath
Register_All_Open_WB dWB

For Each cell In rngData
    wbName = cell & ".xlsx"
    If Not dWB.Exists(wbName) Then
        NewWorkbook FPath, cell, 1
        dWB.Add wbName, Nothing
        Set wb = Workbooks(wbName)
        Set ws = wb.Sheets("Sheet1")
        wsTmp.Cells.Copy ws.Range("A1")
    Else
        Set wb = Workbooks(wbName)
        Set ws = wb.Sheets("Sheet1")
    End If
    nNext = ws.Cells(Rows.Count, "A").End(xlUp).Offset(1).Row
    If nNext = 1 Then nNext = 4
    wsData.Range("A" & cell.Row, "I" & cell.Row).Copy ws.Range("A" & nNext)
Next

Save_And_Close_All_WB wbData, FPath

End Sub

Sub Register_All_Open_WB(dict As Object)

Dim wb As Workbook
Dim wbName As String

Set dict = CreateObject("Scripting.Dictionary")

'Loop through all workbooks
For Each wb In Application.Workbooks
    dict.Add wb.Name, Nothing
Next

End Sub

Sub Open_All_WB_in_Folder(FPath As String)

Dim DialogBox As FileDialog
Dim FileOpen As String

On Error Resume Next
Set DialogBox = Application.FileDialog(msoFileDialogFolderPicker)
If DialogBox.Show = -1 Then
    FPath = DialogBox.SelectedItems(1)
End If
If FPath = "" Then Exit Sub
FileOpen = Dir(FPath & "\*.xlsx*")

Do While FileOpen <> ""
    Workbooks.Open FPath & "\" & FileOpen
    FileOpen = Dir
Loop

End Sub

Sub Save_And_Close_All_WB(wbData As Workbook, FPath As String)

Dim wb As Workbook

For Each wb In Application.Workbooks
    If Not wb.Name = wbData.Name Then
        wb.Close SaveChanges:=True
    End If
Next

End Sub


Function NewWorkbook(ByVal wbPath As String, ByVal wbName As String, ByVal wsCount As Integer) As Workbook

Dim OriginalWorksheetCount As Long
Dim NewName As String

Set NewWorkbook = Nothing
If wsCount < 1 Or wsCount > 255 Then Exit Function
OriginalWorksheetCount = Application.SheetsInNewWorkbook
Application.SheetsInNewWorkbook = wsCount
Set NewWorkbook = Workbooks.Add
NewName = wbPath & "\" & wbName
ActiveWorkbook.SaveAs NewName
Application.SheetsInNewWorkbook = OriginalWorksheetCount

End Function
I am sorry, would you put in bold, wich variables I need to personnalize
 

Zot

Well-known Member
Joined
Nov 26, 2020
Messages
1,883
Office Version
  1. 2016
Platform
  1. Windows
Create a workbook with 2 sheets at least. I had it exactly like the one like @andyporter1975 example since reply his thread here. Sheet1 is data and the other sheet I name it as Template. The macro is in this workbook. Then create a Folder where you want to save all your resulting workbook, any name.

Run the macro. You will be asked for the location of the Folder. Browse and select it. This will create the FPath value. No need to do anything.

The Set rngData = wsData.Range("A4", wsData.Cells(Rows.Count, "A").End(xlUp)) defines the range of name in Data sheet (Sheet1) which is Store A, Store B, etc, starting from A4 down to end of line.

The macro will open all the files in the designated folder so that data can be copied into and register all the file names in a Dictionary for easy checking.

The macro will loop through all the name in the range. If the name matched with the existing file, it will copy the data in that row from column A to I in sample and paste to destination file at ws.Range("A" & nNext) below.
wsData.Range("A" & cell.Row, "I" & cell.Row).Copy ws.Range("A" & nNext)

The line
nNext = ws.Cells(Rows.Count, "A").End(xlUp).Offset(1).Row
will determine the next empty row to place the copied data from the Data sheet (SHeet1)

If file with same name such as Store A did not exist, a file will be created by this line
NewWorkbook FPath, cell, 1

the cell value gives the new file the name (no need to anything) and the 1 is just creating the file with 1 sheet only.

Basically nothing much you need to do for the sample. It is just depends on how your data and template looks like. If they are different, then just need to write code to copy from where to where.

I hope the explanation is very clear to understand how the code works.

Rich (BB code):
Sub CompileData()

Dim nNext As Long
Dim FPath As String, wbName As String
Dim cell As Range, rngData As Range
Dim ws As Worksheet, wsData As Worksheet, wsTmp As Worksheet
Dim wb As Workbook, wbData As Workbook
Dim dWB As Object

Set wbData = ActiveWorkbook
Set wsData = wbData.Sheets("Sheet1")
Set wsTmp = wbData.Sheets("Template")
Set dWB = CreateObject("Scripting.Dictionary")

Set rngData = wsData.Range("A4", wsData.Cells(Rows.Count, "A").End(xlUp))

Application.ScreenUpdating = False

Open_All_WB_in_Folder FPath
Register_All_Open_WB dWB

For Each cell In rngData
    wbName = cell & ".xlsx"
    If Not dWB.Exists(wbName) Then
        NewWorkbook FPath, cell, 1
        dWB.Add wbName, Nothing
        Set wb = Workbooks(wbName)
        Set ws = wb.Sheets("Sheet1")
        wsTmp.Cells.Copy ws.Range("A1")
    Else
        Set wb = Workbooks(wbName)
        Set ws = wb.Sheets("Sheet1")
    End If
    nNext = ws.Cells(Rows.Count, "A").End(xlUp).Offset(1).Row
    If nNext = 1 Then nNext = 4
    wsData.Range("A" & cell.Row, "I" & cell.Row).Copy ws.Range("A" & nNext)
Next

Save_And_Close_All_WB wbData, FPath

End Sub

Sub Register_All_Open_WB(dict As Object)

Dim wb As Workbook
Dim wbName As String

Set dict = CreateObject("Scripting.Dictionary")

'Loop through all workbooks
For Each wb In Application.Workbooks
    dict.Add wb.Name, Nothing
Next

End Sub

Sub Open_All_WB_in_Folder(FPath As String)

Dim DialogBox As FileDialog
Dim FileOpen As String

On Error Resume Next
Set DialogBox = Application.FileDialog(msoFileDialogFolderPicker)
If DialogBox.Show = -1 Then
    FPath = DialogBox.SelectedItems(1)
End If
If FPath = "" Then Exit Sub
FileOpen = Dir(FPath & "\*.xlsx*")

Do While FileOpen <> ""
    Workbooks.Open FPath & "\" & FileOpen
    FileOpen = Dir
Loop

End Sub

Sub Save_And_Close_All_WB(wbData As Workbook, FPath As String)

Dim wb As Workbook

For Each wb In Application.Workbooks
    If Not wb.Name = wbData.Name Then
        wb.Close SaveChanges:=True
    End If
Next

End Sub


Function NewWorkbook(ByVal wbPath As String, ByVal wbName As String, ByVal wsCount As Integer) As Workbook

Dim OriginalWorksheetCount As Long
Dim NewName As String

Set NewWorkbook = Nothing
If wsCount < 1 Or wsCount > 255 Then Exit Function
OriginalWorksheetCount = Application.SheetsInNewWorkbook
Application.SheetsInNewWorkbook = wsCount
Set NewWorkbook = Workbooks.Add
NewName = wbPath & "\" & wbName
ActiveWorkbook.SaveAs NewName
Application.SheetsInNewWorkbook = OriginalWorksheetCount

End Function
 

Forum statistics

Threads
1,148,339
Messages
5,746,177
Members
423,998
Latest member
eakenila

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top