loop in advanced filter

Question

I am trying to build a loop that selects different names in an array and uses them in an advanced filter, to copy the filtered data into different sheets. Debug says:trouble with the filter (I used the recording tool).

The final idea is to copy this filtered data into Outlook emails, still a bit far from there, though.

Any idea why it is not working?

Private Sub loopfilter()

Dim VersandRange As Range
Dim rng As Range
Dim Name As String

Set VersandRange = Range("J2", Cells(Rows.Count, "j").End(xlUp))

    For Each rng In VersandRange

        Worksheets("Filtro").Range("AK2") = rng.Value
        Application.CutCopyMode = False
        Worksheets("Alle gemahnten Posten (2)").Range("A1").CurrentRegion.AdvancedFilter Action _
        :=xlFilterCopy, CriteriaRange:=Range("A1:AK2"), CopyToRange:=Range("A5"), _
        Unique:=False

        Range("a5").CurrentRegion.Copy

        Worksheets.Add.Name = rng.Value

        ActiveSheet.Range("A1").Paste

    Next

End Sub

Update 1:

Thanks a lot for the tips

I´ve been trying to make it work this morning, adapting the references. So far it looks like this :

Private Sub loopfilter()

Dim thisWB As Workbook
Dim filterws As Worksheet
Dim howto As Worksheet
Dim advfilter As Range
Dim Postenws As Worksheet
Dim VersandRange As Range
Dim rng As Range
Dim Name As String

Set thisWB = ThisWorkbook
Set filterws = thisWB.Sheets("Filtro")
Set howto = thisWB.Sheets("How to")
Set advfilter = filterws.Range("A1:AK2")
Set Postenws = thisWB.Sheets("Alle gemahnten Posten (2)")
Set VersandRange = howto.Range("J2", Cells(Rows.Count, "j").End(xlUp))

Dim newWS As Worksheet

    For Each rng In VersandRange
        filterws.Range("AK2") = rng.Value
        Application.CutCopyMode = False
        Postenws.Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _
                                                          CriteriaRange:=advfilter, _
                                                          CopyToRange:=filterws.Range("A5"), _
                                                          Unique:=False
        filterws.Range("a5").CurrentRegion.Copy
        Set newWS = thisWB.Sheets.Add
        newWS.Name = rng.Value
        newWS.Range("A1").Paste
    Next

I´m getting trouble with the last 2 lines inside the for loop.

i´ve tried it as

Name = rng.value
newWS.Name = Name

but still not working. Any ideas?

Answer 1

Good start on the code. I'm going to make a couple suggestions to help you avoid some difficulties in debugging.

1. Define and set references to Worksheets and Workbooks. This will help you avoid problems later on when you try to expand your work.

2. Help yourself by defining descriptive names for where your data is coming from and where it's going.

My guess is that your problem(s) are occurring because your Ranges are not specifiying which Worksheet to use. See below for an example:

Option Explicit

Private Sub loopfilter()
    Dim VersandRange As Range
    Dim rng As Range
    Dim Name As String

    Dim thisWB As Workbook
    Dim filterWS As Worksheet
    Dim postenWS As Worksheet
    Dim advFilter As Range
    Set thisWB = ThisWorkbook
    Set filterWS = thisWB.Sheets("Filtro")
    Set postenWS = thisWB.Sheets("Alle gemahnten Posten (2)")
    Set advFilter = filterWS.Range("A1:AK2")

    Set VersandRange = postenWS.Range("J2", _
                          postenWS.Cells(postenWS.Rows.Count, "j").End(xlUp))

    Dim newWS As Worksheet
    For Each rng In VersandRange
        filterWS.Range("AK2") = rng.Value
        Application.CutCopyMode = False
        postenWS.Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _
                                                          CriteriaRange:=advFilter, _
                                                          CopyToRange:=filterWS.Range("A5"), _
                                                          Unique:=False
        filterWS.Range("a5").CurrentRegion.Copy
        Set newWS = thisWB.Sheets.Add
        newWS.Name = rng.Value
        newWS.Range("A1").Paste
    Next

End Sub