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

我希望大家都很好。

我正在寻找一些帮助。 我正在寻找一种工作手册，将主文件中的数据分割成基于列H的各个工作簿。首先需要做的是，需要将列T过滤为“拥有”或“受影响”。 然后H列需要分解成单独的工作簿。 基于列H中的内容。在创build的每个新工作簿上，无论是在H列下面，都需要有两个选项卡，一个是“拥有”选项卡，另一个是“受影响”选项卡。 这将需要然后保存，因为无论单元格的名称和date。

额外的困难位是在列H下，在每个单元格中可以有A，B，C，D，E，F作为单独的单元格，但也可能有多个字母的单元格。 如果他们有多个字母，每个人都需要进入单元格中提到的所有工作簿。 因此，例如，如果有一个单元格A，B，C，D，这意味着它将不得不进入A，B，C和D的单个工作簿的工作簿。

我附上了文件图像 我有我使用的下面的代码。 它确实有效，但是由于上述问题，单元格中的多个标准将工作簿分解为单独的工作簿。 有谁知道是否可以添加一个下拉列表，我可以从列H和T中select标准，或另一个工作周围请。 如果有必要，我很乐意尝试其他代码。 还附有示例工作簿。

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，而不是将filter应用于工作表。 然后，您可以使用行索引列表为每个输出分割数组。

我没有你的源数据（不能看到附件）​​，但这种方法工作？

 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 ie rows & cols .Cells(1, 1).Resize(, UBound(OutputArr, 2)) = HeaderVals .Cells(2, 1).Resize(UBound(OutputArr, 1), UBound(OutputArr, 2)) = OutputArr Else '1D ie 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 ie rows & cols .Cells(1, 1).Resize(, UBound(OutputArr, 2)) = HeaderVals .Cells(2, 1).Resize(UBound(OutputArr, 1), UBound(OutputArr, 2)) = OutputArr Else '1D ie 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 

因为@dwironybuild议它利用列H上的Splitfunction来分离每一行的各种标准，然后将行号存储在一个集合中。

我意识到一个Dictionary将是一个更适合在这里，而不是使用Collections ，但作为字典是Windows只有我更喜欢避免它们，除非我确定该文件只能在Windows上使用。 如果是这种情况，那么上面的代码可以通过将集合切换为字典来简化。

直接将Range对象分配给数组时，@jeeped Excel会创buildbase-1数组。 我一直认为它们与(ROW,COL)地址类似。

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

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

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