MACRO filter column based on reference criteria copy, paste and repeat

[helpmeinoob]

Hi everyone, I've been working on this problem for quite some time now and I'm stuck. Hoping this community can provide some very needed guidance to this newbie :hi:

I've attached a simple workbook. I'd like to filter Column A on Data1 based on the Names tab, paste into PasteData1, and do the same for Data2 - PasteData2 and Data3 - PasteData3, then save down a copy of the workbook with the Name.xlsx and loop to the next name. So the process is this:


Filter Data1 for the first Name on the Names tab
Paste those values onto PASTEData1 tab
Filter Data2 for the first Name on the Names tab
Paste those values onto PASTEData2 tab
Filter Data3 for the first Name on the Names tab
Save down the workbook as Name.xlsx
Repeat for Name 2 on the Names tab


To note, the three data tabs cannot be combined into 1, my actual workbook is more complicated.

Please help!

[p45cal]

It's probably quite easy to write a macro to remove names from Data1, Data2 etc. which aren't the one you want to keep each time and do away with PasteData1, PasteData2 sheets. Would that be allowed?

[helpmeinoob]

Yes that's a good point. I wasn't sure if the paste tabs would make things easier or not. How could I go about that?

[p45cal]

In the meantime I wrote the beginnings of a macro to carry out your original idea:
Sub blah()
With Sheets("Names")
Set rngListOfNames = .Range(.Range("A1"), .Range("A1").End(xlDown))
Set rngListOfNames = Intersect(rngListOfNames, rngListOfNames.Offset(1))
'Application.Goto rngListOfNames
Set rngCriteria = .UsedRange.Offset(, .UsedRange.Columns.Count + 1).Resize(2, 1)
'Application.Goto rngCriteria
rngCriteria.Cells(1).Value = "Name"
End With
Set SourceSheets = Sheets(Array("Data1", "Data2", "Data3"))
Set DestnSheets = Sheets(Array("PASTEData1", "PASTEData2", "PASTEData3"))
For Each cll In rngListOfNames.Cells
rngCriteria.Cells(2).Value = cll.Value
For i = 1 To SourceSheets.Count
'DestnSheets(i).Activate
DestnSheets(i).Range("A1").CurrentRegion.Clear
SourceSheets(i).Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=rngCriteria, CopyToRange:=DestnSheets(i).Range("A1"), Unique:=False
Next i
'Stop
'Save the file here using the name in cll.value
MsgBox "Save here using a name like" & ThisWorkbook.Path & Application.PathSeparator & cll.Value & ".xlsm"
Next cll
rngCriteria.Clear
End Sub
I've just put a message box instead of actually saving the file because how the file is saved depends on what you want saved in these new files; for example, do you want the macros to be included in the file, do you want the Names sheet to be included too? I'd have guessed not, especially if you're sending these files out to people, you might only want to send out a small subset of the sheets, which would actually be easier to code for.

[helpmeinoob]

Thank you so much! I will try this out.

For this approach, I'd like to save the file with the Name that was filtered ie Name.xlsx and keep everything in the workbook.

In my actual workbook I have 6 summary sheets that are driven off of the Data (or PasteData tabs). My plan was to create another macro that will run through all the files select just those 6 sheets, copy paste value, and save it down.

[helpmeinoob]

How do I go about replacing the message box with the Name.xlsx so I can see how it's working?

[p45cal]

There are problems with saving a copy of the file which has the macros in as an xlsx file (without macros), a bit convoluted. I would much prefer to create a separate workbook (.xlsx) for each name and paste copies of the sheets to it, that way you wouldn't need to create a second macro to run through the files again.
So it's just all the Datan sheets and the corresponding PASTEDatan sheets that need to be in the final files?
Bedtime here. I'll revisit tomorrow or the day after.

[helpmeinoob]

Saved as a macro file is fine as well. But what you suggest works too. If you wouldn't mind, how to replace the message box with the Name. xlsm? Thank you for your help.

[p45cal]

Try:
Sub blah()
On Error GoTo errhanldler
Application.ScreenUpdating = False
With Sheets("Names")
Set rngListOfNames = .Range(.Range("A1"), .Range("A1").End(xlDown))
Set rngListOfNames = Intersect(rngListOfNames, rngListOfNames.Offset(1))
Set rngCriteria = .UsedRange.Offset(, .UsedRange.Columns.Count + 1).Resize(2, 1)
rngCriteria.Cells(1).Value = "Name"
End With
Set SourceSheets = Sheets(Array("Data1", "Data2", "Data3")) 'adjust this line if necessary.
Set DestnSheets = Sheets(Array("PASTEData1", "PASTEData2", "PASTEData3")) 'adjust this line if necessary.
For Each cll In rngListOfNames.Cells
rngCriteria.Cells(2).Value = cll.Value
For i = 1 To SourceSheets.Count
DestnSheets(i).Range("A1").CurrentRegion.Clear
SourceSheets(i).Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=rngCriteria, CopyToRange:=DestnSheets(i).Range("A1"), Unique:=False
Next i
DestnSheets.Copy
With ActiveWorkbook
Application.DisplayAlerts = False 'omit this line if you want to be asked about overwriting an existing file.
.SaveAs Filename:=ThisWorkbook.Path & Application.PathSeparator & cll.Value & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
Application.DisplayAlerts = True
.Close
End With
Next cll
For Each sht In DestnSheets
sht.UsedRange.Clear
Next sht
rngCriteria.Clear
errhanldler:
Application.ScreenUpdating = True
End Sub

[helpmeinoob]

Awesome, this worked perfectly thank you for your help! :hi: