Macro to filter on every item in a list, then copy filtered range to another worksheet

[diygail123]

Hi, I wonder if anyone can help me with this, I have a list of vendor codes in column B on a worksheet called "Import", and I need to filter on every vendor code in this list, and copy the filtered range to another worksheet, the name of which will be the vendor code. Below is the code I have recorded, Vendor 000657 being the first vendor that appears when I click on the filter drop down. I can see that the vendor code is being hardcoded, which I dont want, as the vendor codes in the list will change month on month. I can also see that the filtered range is hardcoded, and this is no good either, as this range will change each month.

Can anyone help me? I am a beginner in VBA, but very keen to learn. I was hoping for some kind of loop that filtered on each different vendor code in column B?
Sub New_data()
'
' New_data Macro
'


'FILTER ON FIRST VENDOR
Sheets("Import").Select
ActiveSheet.Range("$A$1:$Q$5000").AutoFilter Field:=2, Criteria1:="000657"

'COPY AND PASTE THE FILTERED RANGE TO VENDOR TAB
Range("A431:F432").Copy
Sheets("657").Select
Range("A4").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Import").Select
Range("H431:K432").Copy
Sheets("657").Select
Range("H4").Select
ActiveSheet.Paste

'FILTER ON SECOND VENDOR
Sheets("Import").Select
ActiveSheet.Range("$A$1:$Q$5000").AutoFilter Field:=2, Criteria1:="000661"

'COPY AND PASTE THE FILTERED RANGE TO VENDOR TAB
Range("A226:F232").Copy
Sheets("661").Select
Range("A4").Select
ActiveSheet.Paste
Sheets("Import").Select
Range("H226:K232").Copy
Sheets("661").Select
Range("H4").Select
ActiveSheet.Paste

 

[Fluff]

Hi & welcome to MrExcel.
How about

Sub CopyFltr()
   Dim Ws As Worksheet
   Dim Cl As Range
   
   Application.ScreenUpdating = False
   Set Ws = Sheets("Import")
   If Ws.AutoFilterMode Then Ws.AutoFilterMode = False
   With CreateObject("Scripting.dictionary")
      For Each Cl In Range("b2", Ws.Range("b" & Rows.Count).End(xlUp))
         If Not .exists(Cl.Value) Then
            .add Cl.Value, Nothing
            Ws.Range("A1:Q1").AutoFilter 2, Cl.Value
            Sheets.add(, Sheets(Sheets.Count)).Name = Cl.Value
            Ws.AutoFilter.Range.Copy Sheets(Cl.Value).Range("A1")
         End If
      Next Cl
   End With
   Ws.AutoFilterMode = False
End Sub

 

[diygail123]

Thank you so much!! That works perfectly! Now all I have to do is try to understand how it is working. What is the Scripting Dictionary? I havent come across that before.

Gail

 

[Fluff]

Glad to help & thanks for the feedback.

For more info on Dictionaries have a look here https://excelmacromastery.com/vba-dictionary/

 

[diygail123]

Hi

I have just tried to run the macro using F5, rather than F8'ing through it, and it bugsat : For Each Cl In Range("b2", Ws.Range("b" & Rows.Count).End(xlUp))

I havent know a macro do that before, do you know why it might be please?

Thanks

Gail

 

[Fluff]

I missed the bit in red on this line

For Each Cl In [COLOR=#ff0000]Ws.[/COLOR]Range("b2", Ws.Range("b" & Rows.Count).End(xlUp))

 

[diygail123]

Thanks, its now bugging at If Not .exists(Cl.Value) Then

The .exists bit is highlighted in yellow.

How come it works with F8, but not F5?

Thanks again

Gail

 

[Fluff]

What error message do you get?

 

[diygail123]

Hi

Its: Compile error: Invalid or unqualified reference

 

[Fluff]

Check that you don't have any subs or variables called Exists.
Also is this the code you are using

Sub CopyFltr()
   Dim Ws As Worksheet
   Dim Cl As Range
   
   Application.ScreenUpdating = False
   Set Ws = Sheets("Import")
   If Ws.AutoFilterMode Then Ws.AutoFilterMode = False
   With CreateObject("Scripting.dictionary")
      For Each Cl In Ws.Range("B2", Ws.Range("B" & Rows.Count).End(xlUp))
         If Not .Exists(Cl.Value) Then
            .Add Cl.Value, Nothing
            Ws.Range("A1:Q1").AutoFilter 2, Cl.Value
            Sheets.Add(, Sheets(Sheets.Count)).Name = Cl.Value
            Ws.AutoFilter.Range.Copy Sheets(Cl.Value).Range("A1")
         End If
      Next Cl
   End With
   Ws.AutoFilterMode = False
End Sub