VBA Creating Worksheets and Saving to Workbooks based on two columns

[Julmust Jaeger]

Hello,

I am a neophyte to VBA trying to automate some tasks.

Conceptually, I have a file of raw data (around 18,000 rows and 10 columns).

First, I would like to loop through the entire document and select cells in Column A (product codes) based on company values in Column B. Using the values from Column A I would create worksheets for each product code (I have a template where cell B1 is based on the worksheet name and this B1 value is used to populate the template). Once each product for a company (around 1-10) has a generated worksheet from this template, I would then need to save it to a company specific workbook.

Thereafter this process should repeat for each following company.

I have managed the follow code, but it feels quite inefficient (especially manually selecting the cells to generate worksheets from). If anyone has tips or advice I would appreciate it!

The process I have is as follows --> Select cells manually that represent all product codes for a company --> Generate sheets using Macro 1 (creating copies of the template and populating them with data by changing cell B1 on each sheet to be the name of the worksheet) --> Save generated sheets using Macro 2 --> delete all sheets except product list and template sheet

Generating Worksheets based on product codes:

Sub Generate_Sheets_by_Product_Code_and_Company()
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

Saving generated worksheets:

Sub DeleteSheetsByNotName()


    Dim ws As Worksheet
    
    For Each ws In Worksheets
        If (ws.Name <> "Product_List") And (ws.Name <> "Template") Then
            Application.DisplayAlerts = False
            Sheets(ws.Name).Delete
            Application.DisplayAlerts = True
        End If
    Next ws


End Sub

Deleting generated worksheets (so template is free to use again):

Sub SaveSheetsByNotName()
    Dim sh As Worksheet
    Dim ArraySheets() As String
    Dim x As Variant
    Dim MyDir As String
    Dim TabName As String
    Dim newFileName As String
    newFileName = ActiveSheet.Range("B2").Value

    MyDir = "H:\Big Projects\3 Month Report"
    TabName = 2018
    For Each sh In ActiveWorkbook.Worksheets
        If (sh.Name <> "Product_Lists") And (sh.Name <> "Template") Then
            ReDim Preserve ArraySheets(x)
            ArraySheets(x) = sh.Name
            x = x + 1
        End If
    Next sh

    Sheets(ArraySheets).Copy    'change to move if you want to move the sheets

    With ActiveWorkbook
        .SaveAs MyDir & newFileName & ".xlsb", FileFormat:=50     'xlExcel12 Binary
        .Close
    End With
End Sub