VBA Autofiltering and then Generating Worksheets from a Template

[Julmust Jaeger]

Hello!

I would love some help to streamline my VBA pipeline that I use to generate worksheets from a list, populating these worksheets using a template, and then saving them to company specific workbooks.

"Accounts" has three Columns: A I have account numbers (all unique) and Column B companies (some repeat)
"Data" has a large number of individual invoices from each of the above accounts
"Template" is a worksheet that I have setup so that when I rename the worksheet, the value in B1 becomes this name, and then this in turn runs formulas I have placed on the worksheet to pull relevant information from the "Data" worksheet
Accounts:

Data:

Template:


Right now I have a very basic, but quite slow process as a lot of it is still manual.

First I create several workbooks using an autofilter (courtesy of Dante Amour):

        Sub create_worksheets_and_workbooks()
Dim c As Range, sh As Worksheet, ky As Variant
Dim lr As Long
 
Application.ScreenUpdating = False
Application.DisplayAlerts = False
 
Set sh = Sheets("Accounts")   
lr = sh.Range("A" & Rows.Count).End(xlUp).Row
With CreateObject("scripting.dictionary")
For Each c In sh.Range("A2:A" & lr)
If c.Value <> "" Then .Item(c.Value) = Empty
Next c
For Each ky In .Keys
On Error Resume Next: Sheets(ky).Delete: On Error GoTo 0
sh.Range("A1:C" & lr).AutoFilter Columns("A").Column, ky
Sheets.add(, Sheets(Sheets.Count)).Name = ky
sh.AutoFilter.Range.EntireRow.Copy Range("A1")
Sheets(Array(ky, "Template", "Data")).Copy
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & ky & ".xlsx", xlOpenXMLWorkbook
ActiveWorkbook.Close False
On Error Resume Next: Sheets(ky).Delete: On Error GoTo 0
Next ky
End With
sh.Select
sh.ShowAllData
 
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

Then I manually open each file and manually select the appropriate range from "Accounts" worksheet.

        Sub Generate_Sheets_by_Account()
Dim rng As Range
Dim cell As Range
'Show inputbox to user and prompt for a cell range
Set rng = Application.InputBox(Prompt:="Select cell range:", _
Title:="Create sheets", _
Default:=Selection.Address, Type:=8)

Dim ws As Worksheet, Ct As Long
Set ws = Worksheets("Template")
Application.ScreenUpdating = False
 
'Iterate through cells in selected cell range
For Each cell In rng
 
'Check if cell is not empty
If cell <> "" Then
 
'Insert worksheet and name the worksheet based on cell value
'ws.Copy after:=Sheets("Template")
ws.Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = cell.Value
Ct = Ct + 1
End If

'continue with next cell in range
Next cell
If Ct > 0 Then
MsgBox Ct & " new sheets created from list"
Else
MsgBox "No names on list"
End If
Application.ScreenUpdating = True

'Stop Macro
End Sub

Then I replace the formulas in the account worksheets by copy and pasting columns A:C. I tried and so far failed to write a neat way to just loop through the individual account worksheets to remove the formulas in this range (I have other formulas on the worksheet I don't wish to strip outside of this range).

Sub Trim_Formulas
Range("A:C") = Range("A:C").Value
End Sub

Finally, I delete the worksheets with the data (named after the company), Template, and Accounts. I wrote some code to do this, but then struggled as I wasn't sure how to account for the company name (there are 87 companies).

---

Ultimately what I would like to try to do is more efficiently pull create individual account worksheets (creating/naming them from a list of accounts, then copy/pasting the template, so that data is populated from each account, and then saving each worksheet based on the particular company).

There are about 90 companies and a fair amount of invoices (50,000+).

Thanks for any help!