根據特定列中的動態值創建新工作表

Question

例如，給定 B 列中的一系列值 - 我們只有從B4到B5的 2 個值，其中12在B4中， 99在B5中。

對於 B 列中的每個值（我們稱之為product code ）（這里是12和99 ），我想：

1. 創建現有工作表“Order”的副本，並將名為“Symbol”(C2) 的單元格替換為產品代碼（集合中的值）
2. 使用單元格中的值（產品代碼）命名新工作表

技巧：值的數量是動態的，它肯定以B4開頭，但可能以 B 列中的任何值結尾

對於代碼，我認為邏輯應該是：

##(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

但是，我不確定

(1) 如何獲取列中的值並將它們存儲在集合中以方便第二步？

(2) 也許我可以在第二步做類似下面的事情：

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

但是這里我們需要對我們在步驟1中生成的集合中的每一個item都做，並根據item值（集合中的商品編碼）來命名。

任何幫助將不勝感激，在此先感謝。

Answer 1

添加工作表

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