Split Workbook into multiple workbooks based on two columns - vba

Question

I hope everyone is well.
I am look for some help. I am looking to automate a workbook which splits the data from the master file to the individual workbooks based on column H. What needs to be done first is that Column T needs to be filtered to 'Owned' or 'Impacted'. Column H then needs to be split into the separate workbooks. based on what may be in column H. On each new workbook created, whatever is under column H there needs to be two tabs, one tab for 'Owned' and one tab for 'Impacted'. This would need to be then saved as whatever the name of the cell was and the date.
The additional difficult bit is under column H, in each cell as per the attached there could be A, B, C, D, E, F as individual cells, but there could also be cells with multiple letters in them. If they have multiple letters each one needs to go into all the workbooks that are mentioned in the cell. So, for example if there is a cell with A, B, C, D, this would mean it would have to go into the workbook for the individual workbooks for A, B, C, and D.
I have attached the file image and I have the below code which I used. It does work, however due to the above issue with the multiple criteria in the cells it is splitting the workbooks further into individual workbooks. Does anyone know if a drop down can be added where I can select the criteria from column H and T, or another work around please. I am happy to try another code if necessary. Example workbook attached as well.
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
Any help would be appreciated. Thank in advance

Answer 1

Rather than applying filters to the worksheet you could load the entire dataset into an array and then store the row index #s for each of the various criteria. You can then use the row index lists to slice the array for each respective output.
I don't have your source data (couldn't see the attached file) but would this approach work?
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
as #dwirony suggested it utilizes the Split function on col H to break apart the various criteria on each row and then stores the row # in a collection.
I realize a Dictionary would be a better suited here rather than using Collections, however as Dictionaries are Windows only I prefer to avoid them unless I know for certain the file will only ever be used on Windows. If this is the case then the above code could be simplified by switching the collections out for a dictionary.
#jeeped Excel creates base-1 arrays when directly assigning a Range object to an array. I've always assumed to make them similar to the (ROW,COL) addressing.
==== Edit 6/30 ====
Updated code to reflect changes to data layout:
Additional cols in data range
Owned/Impacted col moved to Col W
Adjusted Worksheet reference to match OPs request