Question

我希望每个人都很好。

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

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

我附加了文件图片，我使用了以下代码。它确实有效，但是由于上述单元格中的多个标准问题，它将工作簿进一步分解为单独的工作簿。有没有人知道是否可以添加下拉列表，我可以从列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，我宁愿避免使用它们，除非我确定该文件只会被用于视窗。如果是这种情况，则可以通过将集合切换为字典来简化上述代码。

@jeeped Excel在直接将Range对象分配给数组时创建base-1数组。我总是假设它们与(ROW,COL)寻址类似。

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

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

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

基于两列

1 个答案: