Filter column based on reference criteria

alkaline3 · Jan 24th 2020

Hi everyone, I'm putting together a larger macro but need help with the first step...hoping you can provide some guidance

Here is some code, instead of Criteria being the specific Name ie Criteria1:= "Rodgers, Aaron", I'd like it to reference a Names tab. So it would select the first name on Names tab, copy the selection, and paste it into another tab. Thank you very much

Code

Sub test()
'
' test Macro
'

'
    Sheets("Detail").AutoFilter Field:=2, Criteria1:= _
    Sheets("Names").Select
    Range("A2").Select
    Cells.Select
    Selection.Copy
    Sheets("PASTE").Select
    Cells.Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
End Sub

Display More

**royUK** · Jan 24th 2020

I don't understand your code what's all the selecting for? I doubt if it does what you want.

Explain fully what you are planning. It's OK you assuming that the steps you have in mind are correct, but there could be a simpler, more efficient way.

alkaline3 · Jan 24th 2020

Thank you for the response.

My overall plan is to filter Column A on 3 different tabs for the name referenced on a criteria tab, select the contents, paste into 3 new tabs, and save down a new workbook.

But I'm trying to break it into manageable steps for myself. So, I thought filtering 1 tab for Column A that references the first name found on Names tab would be a good first step.

**royUK** · Jan 24th 2020

Can you attach an example workbook

alkaline3 · Jan 24th 2020

Here's 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.xslx and loop to the next name.

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

alkaline3 · Jan 24th 2020

Also, if it makes more sense to do away with the PasteData tabs and just filter the 3 Data tabs based on the criteria each time then that works too.

**royUK** · Jan 25th 2020

Why have you got 3 data tabs? All data should be on sheeet.

Why do you need to copy to another sheet, what is the next step? You can probably avid copy and pasting. do you intend making a new workbook for each unique name?

alkaline3 · Jan 25th 2020

I included just a very simple workbook, the three data tabs cannot be combined into 1, my actual workbook is more complicated.

I thought the 3 paste tabs might be easier, but like you say, likely makes more sense to filter the 3 data tabs. Once the 3 tabs are filtered based on the Names criteria tab, I'd like the workbook saved down with the Name.xlsx or Name.xlsm (whatever is easier) and then loop the same process for the next name...

alkaline3 · Jan 25th 2020

I have some code here:

How can I save the files as Name.xlsm? Does not seem to be working for me..I'd like the files saved in the same directory

Code

Sub Filter()
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 nme In rngListOfNames.Cells
  rngCriteria.Cells(2).Value = nme.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 nme.value
  '??? How to save??? & ThisWorkbook.Path & Application.PathSeparator & cll.Value & ".xlsm"
Next nme
rngCriteria.Clear
End Sub

Display More

**royUK** · Jan 25th 2020

Try this

Code

Sub Filter()
Dim NewName As String
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 nme In rngListOfNames.Cells
rngCriteria.Cells(2).Value = nme.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 nme.value
'??? How to save??? & ThisWorkbook.Path & Application.PathSeparator & cll.Value & ".xlsm"
''/// makes a copy of the sheet in a new workbook
DestnSheets(i).Copy
''/// ask user for a name for the new workbook
NewName = Application.GetSaveAsFilename
If NewName <> False Then
ActiveWorkbook.SaveAs Filename:=NewName, FileFormat:=51
End If
Next nme
rngCriteria.Clear
End Sub

Display More

You could skip asking for a name by using the rngcriteria if that is the name you have filtered for

Code

''/// makes a copy of the sheet in a new workbook
DestnSheets(i).Copy
''/// ask user for a name for the new workbook
NewName = Application.GetSaveAsFilename
If NewName <> False Then
ActiveWorkbook.SaveAs Filename:=rngCriteria, FileFormat:=51
End If

Code

''/// makes a copy of the sheet in a new workbook
DestnSheets(i).Copy
''/// ask user for a name for the new workbook
NewName = Application.GetSaveAsFilename
If NewName <> False Then
ActiveWorkbook.SaveAs Filename:=NewName, FileFormat:=51
End If

alkaline3 · Jan 25th 2020

Thank you! I'm just having one out of range error with the:

Code

DestnSheets(i).Copy

Am I missing a step? Probably something obvious...

Code

Sub Filter()
Dim NewName As String
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 nme In rngListOfNames.Cells
rngCriteria.Cells(2).Value = nme.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 nme.value
'??? How to save??? & ThisWorkbook.Path & Application.PathSeparator & cll.Value & ".xlsm"
''/// makes a copy of the sheet in a new workbook
''/// makes a copy of the sheet in a new workbook
DestnSheets(i).Copy
''/// ask user for a name for the new workbook
NewName = Application.GetSaveAsFilename
If NewName <> False Then
ActiveWorkbook.SaveAs Filename:=NewName, FileFormat:=51
End If
Next nme
rngCriteria.Clear
End Sub

Display More

alkaline3 · Jan 25th 2020

I would like to avoid the prompt for the Name and just set it as the Name that was filtered for..

**royUK** · Jan 25th 2020

Try the amended code

Code

Sub Filter()
Dim NewName As String
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 nme In rngListOfNames.Cells
rngCriteria.Cells(2).Value = nme.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 nme.value
'??? How to save??? & ThisWorkbook.Path & Application.PathSeparator & cll.Value & ".xlsm"

DestnSheets(i).Copy
''/// makes a copy of the sheet in a new workbook
DestnSheets(i).Copy
ActiveWorkbook.SaveAs Filename:=NewName, FileFormat:=51

Next nme
rngCriteria.Clear
End Sub

Display More

alkaline3 · Jan 25th 2020

Still seem to have error on the DestnSheets(i).Copy line..

**royUK** · Jan 25th 2020

I don't know what DestnSheets(i) is. When you get the error hover the cursor over that and see what the value is, it will show in intellisense.

What error message are you getting?

Maybe this

Code

Sub Filter()
Dim NewName As String
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 nme In rngListOfNames.Cells
rngCriteria.Cells(2).Value = nme.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 nme.value
'??? How to save??? & ThisWorkbook.Path & Application.PathSeparator & cll.Value & ".xlsm"

DestnSheets(i).Copy
''/// makes a copy of the sheet in a new workbook
DestnSheets(i).Copy
ActiveWorkbook.SaveAs Filename:=rngCriteria.Value, FileFormat:=51

Next nme
rngCriteria.Clear
End Sub

Display More

alkaline3 · Jan 25th 2020

When I run the code I get Subscript out of range error and when I hit debug it highlights DestnSheets(i).Copy, when I hover over the highlighted line I don't see any detail

**royUK** · Jan 25th 2020

That should refer to the destination sheet. Replace it with WorkSheets(sheet name) - put the actual name of the sheet you have copied to in place of sheet name

alkaline3 · Jan 25th 2020

I'm not sure I'm following ... I have 3 sheets I've copied to. I think this code was close except I need to replace this line somehow for it to save out the files as it filters through

Code

 'Save the file here using the name in nme.value '??? How to save??? & ThisWorkbook.Path & Application.PathSeparator & nme.Value & ".xlsm"

Code

Sub Filter()
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 nme In rngListOfNames.Cells
 rngCriteria.Cells(2).Value = nme.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 nme.value
 '??? How to save??? & ThisWorkbook.Path & Application.PathSeparator & nme.Value & ".xlsm"
Next nme
rngCriteria.Clear
End Sub

Display More

**royUK** · Jan 25th 2020

I don't think your code is helping.

Let me check

1. You have 3 sheets with names in

2. You need to filter each of those lists to create a new workbook with each name's data.

3. Are you needing data from each source sheet into the new workbook?

Let me know if I'm wrong and add anything I might have missed then I'll write some code using your sample workbook

alkaline3 · Jan 25th 2020

Awesome, I really appreciate your help. I have to filter each of the 3 Data tabs for each Name in the Name criteria tab, except I also need to either clear the contents after the filter that don't meet that criteria, or paste into another worksheet.

My actual workbook is a bit more complicated and I have references these worksheets so I need the cells to line up properly.

So process is:

1. You have 3 sheets with names in - Yes Names are all in Column A

2. You need to filter each of those lists to create a new workbook with each name's data. - Yes, but with just that Names criteria, so either cleared for other Names data or Pasted into PasteData tab

3. Are you needing data from each source sheet into the new workbook? - Yes, I'd like the full workbook saved down

Thank you again, let me know any other questions

Filter column based on reference criteria

Participate now!

Share

Tags