CODEWITHSUNDEEP
excelvbaautofilter
w97802
w97802

Reputation: 121

Create new sheets based on dynamic values in certain column

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:

  1. 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)
  2. 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.

Upvotes: 1

Views: 226

Answers (1)

VBasic2008
VBasic2008

Reputation: 54838

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

Upvotes: 1

Related Questions