Macro help for cutting reports by name - excel

Question

I have the below macro that cuts my report up by name (when it asks me which column to filter on, its 2).
It works perfectly for I need, as it also saves down each cut per person for each report where the report is saved. However, I also need it to pick up everything by name of person in all other tabs in the report. EG: Dave Smith is on the main summary page, and the below macro cuts it by Dave Smith, and saves that cut down. But Dave Smith also has data in 7/8 other tabs, that also need to be included in the new, saved down cut.
Sub parse_data()
'This macro splits data into multiple worksheets
'based on the variables on a column found in Excel.
'An InputBox asks you which columns you'd like
'to filter by, and it just creates these worksheets.
Const TITLE_ROW = 1
Dim wbOut As Workbook
Dim ws As Worksheet, wsOut As Worksheet
Dim iLastRow As Long, iRow As Long
Dim iFilterCol As Integer
Dim sPath As String
' get filter column nu,ber
iFilterCol = Application.InputBox( _
prompt:="Which column would you like to filter by?", _
title:="Filter column", Default:="3", Type:=1)
If iFilterCol < 1 Then
MsgBox iFilterCol & " not valid", vbCritical
Exit Sub
End If
Set ws = ActiveSheet
sPath = ThisWorkbook.Path & "\"
iLastRow = ws.Cells(ws.Rows.Count, iFilterCol).End(xlUp).Row
Dim dict As Object, key
Set dict = CreateObject("Scripting.Dictionary")
' get unique values using dictionary
For iRow = TITLE_ROW + 1 To iLastRow
key = Trim(ws.Cells(iRow, iFilterCol))
If Not dict.exists(key) Then
dict.Add key, iRow
End If
Next
' create separate workbooks
Application.ScreenUpdating = False
For Each key In dict
' apply filter
ws.Rows(TITLE_ROW).AutoFilter Field:=iFilterCol, Criteria1:=key
' create new workbook
Set wbOut = Workbooks.Add
Set wsOut = wbOut.Sheets(1)
wsOut.Name = key
ws.Range("A" & TITLE_ROW & ":A" & iLastRow).EntireRow.Copy wsOut.Range("A1")
wsOut.Columns.AutoFit
' save and close
wbOut.SaveAs (sPath & key & ".xlsx")
wbOut.Close False
Next
ws.Activate
ws.AutoFilterMode = False
Application.ScreenUpdating = True
MsgBox dict.Count & " workbooks created", vbInformation
End Sub

Answer 1

Use Find to locate the filter column for the other sheets, apply filter and repeat the code for the first sheet.
Option Explicit
Sub parse_data()
'This macro splits data into multiple worksheets
'based on the variables on a column found in Excel.
'An InputBox asks you which columns you'd like
'to filter by, and it just creates these worksheets.
Const TITLE_ROW = 1
Dim wbOut As Workbook, wb As Workbook
Dim ws As Worksheet, wsOut As Worksheet, wsOther As Worksheet
Dim rng As Range
Dim iLastRow As Long, iRow As Long, iLastOther As Long
Dim iFilterCol As Integer, n As Integer
Dim sPath As String, sSummary As String
' get filter column nu,ber
iFilterCol = Application.InputBox( _
prompt:="Which column would you like to filter by?", _
Title:="Filter column", Default:="3", Type:=1)
If iFilterCol < 1 Then
MsgBox iFilterCol & " not valid", vbCritical
Exit Sub
End If
Set wb = ThisWorkbook ' or ActiveWorkbook
Set ws = ActiveSheet
sSummary = ws.Name
sPath = ThisWorkbook.Path & "\"
iLastRow = ws.Cells(ws.Rows.Count, iFilterCol).End(xlUp).Row
Dim dict As Object, key
Set dict = CreateObject("Scripting.Dictionary")
' get unique values using dictionary
For iRow = TITLE_ROW + 1 To iLastRow
key = Trim(ws.Cells(iRow, iFilterCol))
If Not dict.exists(key) Then
dict.Add key, iRow
End If
Next
' create separate workbooks
Application.ScreenUpdating = False
For Each key In dict
' apply filter
ws.Rows(TITLE_ROW).AutoFilter Field:=iFilterCol, Criteria1:=key
' create new workbook
Set wbOut = Workbooks.Add(xlWBATWorksheet) ' 1 sheet
Set wsOut = wbOut.Sheets(1)
wsOut.Name = key
ws.Range("A" & TITLE_ROW & ":A" & iLastRow).EntireRow.Copy wsOut.Range("A1")
wsOut.Columns.AutoFit
' search other worksheets
For Each wsOther In wb.Sheets
If wsOther.Name <> sSummary Then
'find name to get filter column
wsOther.AutoFilterMode = False
Set rng = wsOther.UsedRange.Find(CStr(key), LookIn:=xlValues, lookat:=xlWhole)
If Not rng Is Nothing Then
iLastOther = wsOther.Cells(ws.Rows.Count, rng.Column).End(xlUp).Row
wsOther.Rows(TITLE_ROW).AutoFilter _
Field:=rng.Column, Criteria1:=CStr(key)
n = wbOut.Sheets.Count
Set wsOut = wbOut.Sheets.Add(after:=wbOut.Sheets(n))
wsOut.Name = wsOther.Name
wsOther.Range("A" & TITLE_ROW & ":A" & iLastOther).EntireRow.Copy _
wsOut.Range("A1")
wsOut.Columns.AutoFit
End If
wsOther.AutoFilterMode = False
End If
Next
' save and close
wbOut.SaveAs (sPath & key & ".xlsx")
wbOut.Close False
Next
ws.Activate
ws.AutoFilterMode = False
Application.ScreenUpdating = True
MsgBox dict.Count & " workbooks created", vbInformation
End Sub