Create new sheets based on dynamic values in certain column - excel

Question

Given a range of values in column B, for example - we only have 2 values from B4 to B5, where 12 is in B4 and 99 is in B5.
For each value(we call it product code) in column B (here they are 12 and 99), I want to:
create a duplicate of the existing sheet "Order", and replace the cell which is named "Symbol"(C2) with the product code (the value in the collection)
name the new sheet with the value (product code) in the cell
Trick: The number of values is dynamic, where it definitely starts with B4, but might end with any value in column B
For the code, I am thinking the logic should be:
##(1) get the range of values in column B starting from B4 (which is dynamic)
##(2) loop through all values in the column, create a sheet for each and change its name to the product
However, I am not sure
(1) how to get the values within a column and maybe store them in a collection to facilitate 2nd step?
(2) maybe I can do something like below for the 2nd step:
Dim SourceSheet As Object
Set SourceSheet = ActiveSheet
SourceSheet.Copy After:=SourceSheet
Dim NewSheet As Object
Set NewSheet = ThisWorkbook.Sheets(SourceSheet.Index + 1)
On Error GoTo ERR_RENAME
NewSheet.Name = "InputName"
On Error GoTo 0
But here we need to do it for each item in the collection we have generated in step 1, and name it according to the item value (product code in the collection).
Any help would be greatly appreciated, thanks in advance.

Answer 1

Add Worksheets
Option Explicit
Sub CreateOrders()
' Define constants.
Const PROC_TITLE As String = "Create Orders"
Const DATA_SHEET_NAME As String = "Sheet1" ' adjust!
Const DATA_FIRST_CELL As String = "B4"
Const SOURCE_SHEET_NAME As String = "Order"
Const DST_CELL As String = "C2"
' Reference the workbook.
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Reference the data range.
Dim ws As Worksheet: Set ws = wb.Sheets(DATA_SHEET_NAME)
If ws.AutoFilterMode Then ws.AutoFilterMode = False
Dim rg As Range, rCount As Long
With ws.Range(DATA_FIRST_CELL)
Dim lCell As Range: Set lCell = .Resize(ws.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
If lCell Is Nothing Then
MsgBox "No product IDs found.", vbExclamation, PROC_TITLE
Exit Sub
End If
rCount = lCell.Row - .Row + 1
Set rg = .Resize(rCount)
End With
' Write the values from the data range to an array.
Dim Data() As Variant
If rCount = 1 Then
ReDim Data(1 To 1, 1 To 1): Data(1, 1) = rg.Value
Else
Data = rg.Value
End If
' Write the unique values from the array to a dictionary.
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Dim r As Long, rString As String
For r = 1 To rCount
rString = CStr(Data(r, 1))
If Len(rString) > 0 Then ' not blank
dict(rString) = Empty
End If
Next r
If dict.Count = 0 Then
MsgBox "The product ID column is blank.", vbExclamation, PROC_TITLE
Exit Sub
End If
' Reference the source worksheet.
Dim sws As Worksheet: Set sws = wb.Sheets(SOURCE_SHEET_NAME)
' Create orders.
Application.ScreenUpdating = False
Dim dsh As Object, rKey As Variant, oCount As Long, ErrNum As Long
For Each rKey In dict.Keys
' Check if the order exists.
On Error Resume Next ' defer error trapping
Set dsh = wb.Sheets(rKey)
On Error GoTo 0 ' turn off error trapping
' Create order.
If dsh Is Nothing Then ' the order doesn't exist
sws.Copy After:=wb.Sheets(wb.Sheets.Count) ' copy as last sheet
Set dsh = wb.Sheets(wb.Sheets.Count) ' reference the new last sheet
On Error Resume Next ' defer error trapping
dsh.Name = rKey ' rename
ErrNum = Err.Number
On Error GoTo 0 ' turn off error trapping
If ErrNum = 0 Then ' valid sheet name
dsh.Range(DST_CELL).Value = rKey ' write to the cell
oCount = oCount + 1
Else ' invalid sheet name
Application.DisplayAlerts = False ' delete without confirmation
dsh.Delete
Application.DisplayAlerts = True
End If
'Else ' the order exists; do nothing
End If
Set dsh = Nothing ' reset for the next iteration
Next rKey
Application.ScreenUpdating = True
' Inform.
Select Case oCount
Case 0: MsgBox "No new orders.", vbExclamation, PROC_TITLE
Case 1: MsgBox "One new order created.", vbInformation, PROC_TITLE
Case Else: MsgBox oCount & " new orders created.", _
vbInformation, PROC_TITLE
End Select
End Sub