如何根据列表创建新工作表？

Question

我正在尝试根据另一个名为 GroupFileNames 的工作表中的组名称列表为 sheet10 中找到的每个组创建新工作簿。

为了更轻松地进行故障排除，当前代码创建了新的工作表而不是工作簿。 我已经有了创建工作簿所需的代码。

我的问题是我的代码不会遍历组名列表。 它为第一组（ABC Corp）创建一个工作表并复制其相应的数据，但它永远不会为下一个组（XYZ Corp）创建工作表。

我尝试了不同的循环方式，使用 Do Until、For Each 等。

Sub CreateWkBookByGroupName()
    
    
    Dim Transaction() As Variant
    Dim GroupNameTransactions() As Variant
    Dim TransactionCounter As Long
    Dim GpnTransactionCounter As Long
    Dim Counter As Long
    Dim i As Integer
    Dim gfn As Worksheet
    Set gfn = ThisWorkbook.Sheets("GroupFileNames")
    Dim groupName As String
    
    
    i = 1
    groupName = gfn.Range("A" & i)
    
    'Store entire database in the Transaction array
    Transaction = Range("A1").CurrentRegion
    'Starting in the i row of the database loop through each transaction
    
    For TransactionCounter = i To UBound(Transaction, 1)
       
        'If the thirteenth column contains a value equal to groupName...
        If Transaction(TransactionCounter, 13) = groupName Then
            '...increase the GpnTransactionCounter by 1
            GpnTransactionCounter = GpnTransactionCounter + 1
            
            'Redimension the GroupNameTransaction array with each instance _
            of a GroupName transaction.
            ReDim Preserve _
              GroupNameTransactions(1 To 13, 1 To GpnTransactionCounter)
            'Start a counter to populate the GroupNameTransactions array
            For Counter = 1 To 13
                'The GroupNameTransactions array equals the current transaction
                GroupNameTransactions(Counter, GpnTransactionCounter) _
                  = Transaction(TransactionCounter, Counter)
            Next Counter
        End If
    Next TransactionCounter
    'Add a new sheet
    Worksheets.Add
    'Add the headings in the first row of the Transactions array
    Range("A1:M1") = Transaction
    'Transpose the GroupNameTransaction array onto the new sheet
    Range("A2", Range("A2").Offset(GpnTransactionCounter - 1, 12)) _
    = Application.Transpose(GroupNameTransactions)
    'Autofit columns
    Columns.AutoFit
    
End Sub

此数据应生成两个新工作表，一个用于 ABC 公司，另一个用于 XYZ 公司。每个新工作表应包含属于其组的所有列。

这是我的代码用来与 Sheet10 上的组名进行比较的组名列表。

Answer 1

如果您确实需要创建作为分组数据子集的新工作表，那么嵌套脚本字典是一种有用的数据结构。

Option Explicit

Sub CreateWkBookByGroupName()

    Dim myTransactionsGroupedByName As Scripting.Dictionary
    Set myTransactionsGroupedByName = PopulateTransactionsByGroupName
    
    Dim myGroup As Variant
    Dim myWS As Excel.Worksheet
    For Each myGroup In myTransactionsGroupedByName
    
        With myTransactionsGroupedByName
        
            Set myWS = CreateSheetForGroupName(.Item(myGroup))
            myWS.Name = myGroup
        End With
        
    Next
    
End Sub


Public Function CreateSheetForGroupName(ByVal NamedGroup As Scripting.Dictionary) As Excel.Worksheet

    Static myHeadingRow As Excel.Range
    
    If myHeadingRow Is Nothing Then
    
        Set myHeadingRow = NamedGroup.Item(0)
        Set CreateSheetForGroupName = Nothing
        Exit Function
        
    End If
    
    Dim myWS As Excel.Worksheet
    Set myWS = ThisWorkbook.Worksheets.Add
    
    myWS.Range("A1").Value = myHeadingRow
    myHeadingRow.Copy Destination:=myWS.Range("A1")
    Dim myTransaction As Variant
    For myTransaction = 0 To NamedGroup.Count - 1
    
        NamedGroup(myTransaction).Copy Destination:=myWS.Range("A" & CStr(myTransaction + 2))
    
    Next
    
    Set CreateSheetForGroupName = myWS
    
End Function


Public Function PopulateTransactionsByGroupName() As Scripting.Dictionary

    Const GroupNameColumn As Long = 13 'Column number for Group Names
    Dim myTransaction As Variant
    
    Dim myGroupedByName As Scripting.Dictionary
    Set myGroupedByName = New Scripting.Dictionary
    For Each myTransaction In Range("A1").CurrentRegion.Rows
    
        Dim GroupName As String
        GroupName = myTransaction.Columns(GroupNameColumn).Cells(1, 1).Value
        
        With myGroupedByName
        
            If Not .exists(GroupName) Then
            
                ' First entry will be the heading rows with a key of "GroupName"
                .Add GroupName, New Scripting.Dictionary
                
            End If
            
            With .Item(GroupName)
            
                .Add .Count, myTransaction
                
            End With
        
        End With
    
    Next
    
    Set PopulateTransactionsByGroupName = myGroupedByName
    
End Function