Create new sheets based on criteria in a table and value in a cell

[SailorJerry7030]

In the first table it's setup like this:

Company	Unit	Product 1	Product 2	Product 3	Product 4	Product 5
Company 1	Unit 2	5​
Company 1	Unit 1	11​
Company 1	Unit 3		4​		5​
Company 2	Unit 1	90​		15​		6​
Company 2	Unit 2		1​
Company 3	Unit 7	4​			7​
Company 4	Unit 3	3​		9​
Company 4	Unit 5	1​				1​
Company 4	Unit 12	4​			6​
Company 5	Unit 1	3​	2​
Company 5	Unit 5				1​	1​
Company 5	Unit 9			5​	7​
Company 5	Unit 10		3​			1​

I'm trying to come up with some code that would create sheets based on the Units, Products, and have a row for each based on the values in the cells. It would look something like this after being ran with a new sheet for each Company:

Company 1	Unit 2	Product 1
Company 1	Unit 2	Product 1
Company 1	Unit 2	Product 1
Company 1	Unit 2	Product 1
Company 1	Unit 2	Product 1
Company 1	Unit 1	Product 1
Company 1	Unit 1	Product 1
Company 1	Unit 1	Product 1
Company 1	Unit 1	Product 1
Company 1	Unit 1	Product 1
Company 1	Unit 1	Product 1
Company 1	Unit 1	Product 1
Company 1	Unit 1	Product 1
Company 1	Unit 1	Product 1
Company 1	Unit 1	Product 1
Company 1	Unit 1	Product 1
Company 1	Unit 3	Product 4
Company 1	Unit 3	Product 4
Company 1	Unit 3	Product 4
Company 1	Unit 3	Product 4
Company 1	Unit 3	Product 4
Company 1	Unit 3	Product 4
Company 1	Unit 3	Product 4
Company 1	Unit 3	Product 4
Company 1	Unit 3	Product 4

Any ideas without bogging down Excel? I think the grand total of rows created would be around 4000 so I don't think it'd be too bad.

 

[Herakles]

In the first table it's setup like this:

Company	Unit	Product 1	Product 2	Product 3	Product 4	Product 5
Company 1	Unit 2	5​
Company 1	Unit 1	11​
Company 1	Unit 3		4​		5​
Company 2	Unit 1	90​		15​		6​
Company 2	Unit 2		1​
Company 3	Unit 7	4​			7​
Company 4	Unit 3	3​		9​
Company 4	Unit 5	1​				1​
Company 4	Unit 12	4​			6​
Company 5	Unit 1	3​	2​
Company 5	Unit 5				1​	1​
Company 5	Unit 9			5​	7​
Company 5	Unit 10		3​			1​

I'm trying to come up with some code that would create sheets based on the Units, Products, and have a row for each based on the values in the cells. It would look something like this after being ran with a new sheet for each Company:

Company 1	Unit 2	Product 1
Company 1	Unit 2	Product 1
Company 1	Unit 2	Product 1
Company 1	Unit 2	Product 1
Company 1	Unit 2	Product 1
Company 1	Unit 1	Product 1
Company 1	Unit 1	Product 1
Company 1	Unit 1	Product 1
Company 1	Unit 1	Product 1
Company 1	Unit 1	Product 1
Company 1	Unit 1	Product 1
Company 1	Unit 1	Product 1
Company 1	Unit 1	Product 1
Company 1	Unit 1	Product 1
Company 1	Unit 1	Product 1
Company 1	Unit 1	Product 1
Company 1	Unit 3	Product 4
Company 1	Unit 3	Product 4
Company 1	Unit 3	Product 4
Company 1	Unit 3	Product 4
Company 1	Unit 3	Product 4
Company 1	Unit 3	Product 4
Company 1	Unit 3	Product 4
Company 1	Unit 3	Product 4
Company 1	Unit 3	Product 4

Any ideas without bogging down Excel? I think the grand total of rows created would be around 4000 so I don't think it'd be too bad.

What name do you want each sheet to have as there is a 31 character limit on worksheet names? Do any of the companies have a name longer than this?

 

[SailorJerry7030]

What name do you want each sheet to have as there is a 31 character limit on worksheet names? Do any of the companies have a name longer than this?

Company name from the first column would be fine and they wouldn’t be longer than the 31 characters

 

[Herakles]

Company name from the first column would be fine and they wouldn’t be longer than the 31 characters

What version of Excel are you using?

 

[SailorJerry7030]

What version of Excel are you using?

Excel 365, version 2307

 

[Fluff]

Excel 365, version 2307

I suggest that you update your Account details (or click your user name at the top right of the forum) so helpers always know what Excel version(s) & platform(s) you are using as the best solution often varies by version. (Don’t forget to scroll down & ‘Save’)

 

[Herakles]

Excel 365, version 2307

Give this a go.

I have assumed that the sheet containing the data is called 'Products'.

You can change it in this line.

Set WsProducts = Worksheets("Products")

It checks for invalid sheet names and orders the sheets in alphabetical order.

Public Sub subCreateWorksheets()
Dim rngData As Range
Dim arrData() As Variant
Dim i As Integer
Dim ii As Integer
Dim WsProducts As Worksheet
Dim Ws As Worksheet
Dim blnExists  As Boolean
Dim WsCompany As Worksheet
Dim intCol As Integer
Dim intRow As Integer
Dim rng As Range
Dim arrCompany() As Variant
Dim intSheets As Integer

On Error GoTo Err_Handler

    ActiveWorkbook.Save
    
    Set WsProducts = Worksheets("Products")
    
    Set rngData = WsProducts.Range("A1").CurrentRegion
        
    Set rngData = rngData.Resize(rngData.Rows.Count - 1, rngData.Columns.Count).Offset(1, 0)
        
    arrCompany = fncGetUnique(rngData.Columns(1))
    
    intSheets = UBound(arrCompany)
        
    For i = LBound(arrCompany) To UBound(arrCompany)
    
        If Not fncIsValidSheetName(arrCompany(i, 1)) Then
            MsgBox "Processing has been aborted.", vbOKOnly, "Warning"
            Exit Sub
        End If
            
        blnExists = False
        
        For Each Ws In Worksheets
            If Ws.Name = arrCompany(i, 1) Then
                Set WsCompany = Worksheets(arrCompany(i, 1))
                blnExists = True
                Exit For
            End If
        Next Ws
        
        If Not blnExists Then
            Worksheets.Add(After:=Sheets(Sheets.Count)).Name = arrCompany(i, 1)
            Set WsCompany = Worksheets(arrCompany(i, 1))
        End If
    
        With WsCompany
            .Cells.ClearContents
            .Range("A1:C1").Value = Array("Company", "Unit", "Product")
        End With
    
    Next i
                
    arrData = rngData
    
    For i = LBound(arrData) To UBound(arrData)
        For intCol = 3 To UBound(arrData, 2)
            If arrData(i, intCol) <> "" Then
                With Worksheets(arrData(i, 1))
                    For ii = 1 To arrData(i, intCol)
                        .Cells(.Cells(.Rows.Count, "A").End(xlUp).Row + 1, 1).Resize(1, 3).Value = Array(arrData(i, 1), arrData(i, 2), WsProducts.Cells(1, intCol).Value)
                    Next ii
                End With
            End If
        Next intCol
    Next i
    
    For i = LBound(arrCompany) To UBound(arrCompany)
        Worksheets(arrCompany(i, 1)).Cells.EntireColumn.AutoFit
    Next i
    
    WsProducts.Activate
               
    MsgBox "Finished creating " & intSheets & " worksheets", vbOKOnly, "Confirmation"
    
Exit_Handler:

    Exit Sub

Err_Handler:

    MsgBox "There has been an error.", vbCritical, "Warning"
        
    Resume Exit_Handler
    
End Sub

Public Function fncIsValidSheetName(ByVal strSheetName As String) As Boolean
Dim arrSheetNameIllegalCharacters() As Variant
Dim i As Integer

    fncIsValidSheetName = False
    
    If Len(strSheetName) = 0 Then
        Exit Function
    End If
    
    If Len(strSheetName) > 31 Then
        MsgBox "Sheet name is longer than 31 characters", vbCritical, "Warning"
        Exit Function
    End If
    
    arrSheetNameIllegalCharacters = Array("/", "\", "[", "]", "*", "?", ":")
        
    For i = LBound(arrSheetNameIllegalCharacters) To UBound(arrSheetNameIllegalCharacters)
        If InStr(strSheetName, (arrSheetNameIllegalCharacters(i))) > 0 Then
            MsgBox "Invalid '" & arrSheetNameIllegalCharacters(i) & "' character in company " & vbCrLf & vbCrLf & strSheetName & ".", vbCritical, "Warning"
            Exit Function
        End If
    Next i

    fncIsValidSheetName = True

End Function