根据两列将工作簿拆分为多个工作簿

Question

希望大家都好。

我正在寻求帮助。我希望自动化一个工作簿，该工作簿根据 H 列将数据从主文件拆分到各个工作簿。首先需要做的是，需要将 T 列过滤为“拥有”或“影响”。然后需要将 H 列拆分为单独的工作簿。基于 H 列中可能包含的内容。在创建的每个新工作簿上，无论 H 列下的内容都需要有两个选项卡，一个选项卡用于“拥有”，一个选项卡用于“受影响”。然后需要将其保存为单元格的名称和日期。

额外的困难位在 H 列下，根据附件，每个单元格中可能有 A、B、C、D、E、F 作为单独的单元格，但也可能有包含多个字母的单元格。如果他们有多个字母，每个字母都需要进入单元格中提到的所有工作簿。因此，例如，如果有一个包含 A、B、C、D 的单元格，这意味着它必须进入 A、B、C 和 D 的各个工作簿的工作簿。

我已经附加了文件 image 并且我有下面的代码，我使用它。它确实有效，但是由于单元格中存在多个标准的上述问题，它会将工作簿进一步拆分为单独的工作簿。有谁知道是否可以添加一个下拉列表，我可以从 H 和 T 列中选择标准，或者请其他解决方法。如有必要，我很乐意尝试其他代码。附上示例工作簿。

Option Explicit

Sub ParseItems()
'Based on selected column, data is filtered to individual workbooks
'workbooks are named for the value plus today's date
Dim LR As Long, Itm As Long, MyCount As Long, vCol As Long
Dim ws As Worksheet, MyArr As Variant, vTitles As String, SvPath As String

'Sheet with data in it
Set ws = Sheets("Master")

'Path to save files into, remember the final \
 SvPath = "\\My Documents\New folder\"

'Range where titles are across top of data, as string, data MUST
'have titles in this row, edit to suit your titles locale
 vTitles = "A1:V1"

'Choose column to evaluate from, column A = 1, B = 2, etc.
 vCol = Application.InputBox("What column to split data by? " & vbLf _
    & vbLf & "(A=1, B=2, C=3, etc)", "Which column?", 8, Type:=1)
  If vCol = 0 Then Exit Sub

'Spot bottom row of data
LR = ws.Cells(ws.Rows.Count, vCol).End(xlUp).Row

'Speed up macro execution
Application.ScreenUpdating = False

'Get a temporary list of unique values from key column
ws.Columns(vCol).AdvancedFilter Action:=xlFilterCopy, 
CopyToRange:=ws.Range("HH1"), Unique:=True

'Sort the temporary list
ws.Columns("HH:HH").Sort Key1:=ws.Range("HH2"), Order1:=xlAscending, 
Header:=xlYes, _
   OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, 
DataOption1:=xlSortNormal

'Put list into an array for looping (values cannot be the result of 
formulas, must be constants)
MyArr = Application.WorksheetFunction.Transpose(ws.Range("HH2:HH" & 
Rows.Count).SpecialCells(xlCellTypeConstants))

'clear temporary worksheet list
 ws.Range("HH:HH").Clear

'Turn on the autofilter, one column only is all that is needed
 ws.Range(vTitles).AutoFilter

'Loop through list one value at a time
For Itm = 1 To UBound(MyArr)
    ws.Range(vTitles).AutoFilter Field:=vCol, Criteria1:=MyArr(Itm)

    ws.Range("A1:A" & LR).EntireRow.Copy
    Workbooks.Add
    Range("A1").PasteSpecial xlPasteAll
    Cells.Columns.AutoFit
    MyCount = MyCount + Range("A" & Rows.Count).End(xlUp).Row - 1

    ActiveWorkbook.SaveAs SvPath & MyArr(Itm) & Format(Date, " MM-DD-YY") & 
  ".xlsx", 51   'use for Excel 2007+
    ActiveWorkbook.Close False

    ws.Range(vTitles).AutoFilter Field:=vCol
  Next Itm

'Cleanup
 ws.AutoFilterMode = False
 MsgBox "Rows with data: " & (LR - 1) & vbLf & "Rows copied to other sheets: 
" & MyCount & vbLf & "Hope they match!!"
Application.ScreenUpdating = True
End Sub

任何帮助将不胜感激。提前致谢

Answer 1

您可以将整个数据集加载到一个数组中，然后为每个不同的条件存储行索引#s，而不是对工作表应用过滤器。然后，您可以使用行索引列表对每个输出的数组进行切片。

我没有您的源数据（看不到附件），但这种方法可行吗？

Sub VariableCollections()

Dim HeaderVals() As Variant
Dim SourceData() As Variant, Criteria As Variant
Dim RowIndexLists As New Collection, ColIndexList As String
Dim KeyStore As New Collection, Key As Variant
Dim i As Long, Temp As String
Dim fName As String, fFormat As Long
Dim OutputArr() As Variant

On Error GoTo ErrorHandler
Application.ScreenUpdating = False

With Sheets("Master") 'change if necessary

    'store table header values in array (A1:W1)
    HeaderVals = .Cells(1, 1).Resize(, 23).Value

    'store data in array, assume starts at A2
    SourceData = .Cells(2, 1).Resize(.Cells(.Rows.Count, 1).End(xlUp).Row, 23).Value

End With

'index row #s for each Criteria & Owned/Impacted
For i = LBound(SourceData, 1) To UBound(SourceData, 1)

    If SourceData(i, 23) = "Owned" Then 'col W

        'loop each Criteria (col H) for current row
        For Each Criteria In Split(SourceData(i, 8), ", ")

            'test if key already added to KeyStore
            If Not InCollection(KeyStore, Criteria) Then KeyStore.Add Criteria, Criteria

            'test if Criteria already added to RowIndexLists
            If InCollection(RowIndexLists, Criteria & "_Own") Then 'already added...

                '...update row index value for current key
                Temp = RowIndexLists(Criteria & "_Own")
                RowIndexLists.Remove (Criteria & "_Own")
                RowIndexLists.Add Temp & "," & i, Criteria & "_Own"

            Else 'not already stored...

                '...Create New Item
                RowIndexLists.Add i, Criteria & "_Own"

            End If

        Next Criteria

    ElseIf SourceData(i, 23) = "Impacted" Then 'col W

        'loop each Criteria (col H) for current row
        For Each Criteria In Split(SourceData(i, 8), ", ")

            'test if key already added to KeyStore
            If Not InCollection(KeyStore, Criteria) Then KeyStore.Add Criteria, Criteria

            'test if Criteria already added to RowIndexLists
            If InCollection(RowIndexLists, Criteria & "_Imp") Then 'already added...

                '...update row index value for current key
                Temp = RowIndexLists(Criteria & "_Imp")
                RowIndexLists.Remove (Criteria & "_Imp")
                RowIndexLists.Add Temp & "," & i, Criteria & "_Imp"

            Else 'not already stored...

                '...Create New Item
                RowIndexLists.Add i, Criteria & "_Imp"

            End If

        Next Criteria

    End If

Next i

'save in same directory as current workbook
fName = Split(ThisWorkbook.FullName, ".")(0)

'set file format # based on OS type
#If Mac Then
    fFormat = 52
#Else
    fFormat = 51
#End If

'assumes cols 8 (H) and 23 (W) are no longer needed in output
ColIndexList = "1,2,3,4,5,6,7,9,10,11,12,13,14,15,16,17,18,19,20,21,22"

'slice HeaderVals array for matching cols
HeaderVals = Application.Index(HeaderVals, 0, Split(ColIndexList, ","))

'write out to new workbooks
For Each Key In KeyStore

    'create new workbook
    With Workbooks.Add

        'output "Owned" matches for current Criteria (key value) if exist
        If InCollection(RowIndexLists, Key & "_Own") Then

            'slice array to indexed rows
            OutputArr = Application.Index(SourceData, _
                        Application.Transpose(Split(RowIndexLists(Key & "_Own"), ",")), _
                        Split(ColIndexList, ","))

            'add new worksheet, rename & output data
            With .Worksheets.Add(After:=.Sheets(.Sheets.Count))

                'rename sheet
                .Name = "Owned"

                'test if OutputArr has 2 dimensions
                If IsArray2D(OutputArr) Then '2D i.e. rows & cols
                    .Cells(1, 1).Resize(, UBound(OutputArr, 2)) = HeaderVals
                    .Cells(2, 1).Resize(UBound(OutputArr, 1), UBound(OutputArr, 2)) = OutputArr
                Else '1D i.e. single row
                    .Cells(1, 1).Resize(, UBound(OutputArr)) = HeaderVals
                    .Cells(2, 1).Resize(, UBound(OutputArr)) = OutputArr
                End If

            End With

        End If

        'output "Impacted" matches for current Criteria (key value) if exist
        If InCollection(RowIndexLists, Key & "_Imp") Then

            'slice array to indexed rows
            OutputArr = Application.Index(SourceData, _
                        Application.Transpose(Split(RowIndexLists(Key & "_Imp"), ",")), _
                        Split(ColIndexList, ","))

            'add new worksheet, rename & output data
            With .Worksheets.Add(After:=.Sheets(.Sheets.Count))

                'rename sheet
                .Name = "Impacted"

                'test if OutputArr has 2 dimensions
                If IsArray2D(OutputArr) Then '2D i.e. rows & cols
                    .Cells(1, 1).Resize(, UBound(OutputArr, 2)) = HeaderVals
                    .Cells(2, 1).Resize(UBound(OutputArr, 1), UBound(OutputArr, 2)) = OutputArr
                Else '1D i.e. single row
                    .Cells(1, 1).Resize(, UBound(OutputArr)) = HeaderVals
                    .Cells(2, 1).Resize(, UBound(OutputArr)) = OutputArr
                End If

            End With

        End If

        'delete sheet1
        Application.DisplayAlerts = False
        .Sheets(1).Delete
        Application.DisplayAlerts = True

        'save file & close
        .SaveAs fName & "_" & Key, fFormat
        .Close

    End With

Next Key

ErrorHandler: If Err.Number <> 0 Then MsgBox "Error # " & Err.Number & " " & Err.Description
Application.ScreenUpdating = True

End Sub

正如@dwirony 建议的那样，它利用col H 上的Split 函数来分解每一行的各种标准，然后将行# 存储在一个集合中。

我意识到Dictionary 比使用Collections 更适合这里，但是由于字典仅适用于 Windows，因此我更愿意避免使用它们，除非我确定该文件只会在 Windows 上使用。如果是这种情况，则可以通过将集合切换为字典来简化上述代码。

@jeeped Excel 在将 Range 对象直接分配给数组时创建 base-1 数组。我一直认为它们类似于(ROW,COL) 寻址。

==== 编辑 6/30 ====

更新代码以反映对数据布局的更改：

• 数据范围内的其他列
• Owned/Impacted col 移至Col W
• 调整了 Worksheet 引用以匹配 OP 请求