Criteria van Autofilter uitlezen

[jansbl]

Dag,

Ik probeer er achter te komen hoe ik alle criteria (van een bepaalde kolom) van een autofilter kan uitlezen.

Met het voorbeeld welke staat in de helpfile van VBA, kom ik niet verder.
Daarmee kan ik wel achterhalen wat een criterium is als deze handmatig is gekozen d.m.v. het autofilter.
Wat ik graag wil is het volgende:
In kolom B heb ik bijv. 15 unieke waarden. Deze kan ik dan selecteren met het Autofilter.
Hoe kan ik deze 15 unieke waarden achterhalen in VBA?

Het voorbeeld welke ik in de helpfile aantrof is de volgende:

Dim w As Worksheet
Dim filterArray()
Dim currentFiltRange As String

Sub ChangeFilters()

Set w = Worksheets("Crew")
With w.AutoFilter
    currentFiltRange = .Range.Address
    With .Filters
        ReDim filterArray(1 To .Count, 1 To 3)
        For f = 1 To .Count
            With .Item(f)
                If .On Then
                    filterArray(f, 1) = .Criteria1
                    If .Operator Then
                        filterArray(f, 2) = .Operator
                        filterArray(f, 3) = .Criteria2
                    End If
                End If
            End With
        Next
    End With
End With

w.AutoFilterMode = False
w.Range("A1").AutoFilter field:=1, Criteria1:="S"

End Sub

 

[Marrosi]

Hallo, goede avond,

Ik begrijp je vraag niet helemaal hoor.

Volgens mij kan je met AUTOFILTER slechts 2 criteria kiezen.

Wanneer je de AUTOFILTER dan loslaat op een lijst met gegevens dan kan krijg je een resultaat dat kan bestaan uit meerdere cellen.

Wil je de resultaten van een AUTOFILTER-bewerking verder bewerken in VBA?

Of bedoel je ADVANCED FILTER?

Graag nog enige verduidelijking.

MVG - Marrosi

 

[jansbl]

Hallo, goede avond,

Ik begrijp je vraag niet helemaal hoor.

Volgens mij kan je met AUTOFILTER slechts 2 criteria kiezen.

Wanneer je de AUTOFILTER dan loslaat op een lijst met gegevens dan kan krijg je een resultaat dat kan bestaan uit meerdere cellen.

Wil je de resultaten van een AUTOFILTER-bewerking verder bewerken in VBA?

Of bedoel je ADVANCED FILTER?

Graag nog enige verduidelijking.

MVG - Marrosi

Dag Marossi,

De resultaten wil ik verder gebruiken in VBA.
Om terug te komen op die kolom B, met 15 unieke waardes: Ik wil een loop maken, waarin ik het autofilter gebruik en dan telkens de waarde van criteria1 wijzig met de eerstvolgende unieke waarde uit die kolom B.

Hoop dat het zo iets duidelijker is.

Groet,
Jans

 

[Marrosi]

Hallo jans,

Echt helemaal duidelijk is het mij nog niet.

Kijk toch al eens naar het bestandje in bijlage.

Dit kan een eerste aanzet zijn maar er moet nog veel aan gebeuren voor het echt werkt hoor.

Run de macro met als naam Test en je ziet de AutoFilter repetitief aan het werk.

We horen wel hoe her verder moet.

Vriendelijke groeten - Marrosi

 

[jansbl]

Hallo jans,

Echt helemaal duidelijk is het mij nog niet.

Kijk toch al eens naar het bestandje in bijlage.

Dit kan een eerste aanzet zijn maar er moet nog veel aan gebeuren voor het echt werkt hoor.

Run de macro met als naam Test en je ziet de AutoFilter repetitief aan het werk.

We horen wel hoe her verder moet.

Vriendelijke groeten - Marrosi

Hallo Marossi,

Dat was niet echt wat ik in gedachten heb.
Ik heb een voorbeelbestandje bijgesloten.
Het is de bedoeling dat ik een kopie van de gegevens van het verzamelblad overbreng naar de andere bladen.
Die andere bladen hebben dezelfde naam als de unieke gegevens in kolom B van het verzamelblad.
Ik wil de routine CopyFilter() van Tom Ogilvy gebruiken:

Sub CopyFilter()

'by Tom Ogilvy
'The following code copies the filtered rows from the active sheet to Sheet2.
On Error Resume Next
Dim rng As Range
Dim rng2 As Range

With ActiveSheet.AutoFilter.Range
 On Error Resume Next
   Set rng2 = .Offset(1, 0).Resize(.Rows.Count - 1, 1) _
       .SpecialCells(xlCellTypeVisible)
 On Error GoTo 0
End With
If rng2 Is Nothing Then
   MsgBox "No data to copy"
Else
   Worksheets("Noord").Cells.Clear
   Set rng = ActiveSheet.AutoFilter.Range
 '  rng.Offset(1, 0).Resize(rng.Rows.Count - 1).Copy
   rng.Offset(0, 0).Resize(rng.Rows.Count).Copy _
     Destination:=Worksheets("Noord").Range("A1")
End If
'   ActiveSheet.ShowAllData


End Sub

Deze code werkt echter alleen als je het autofilter handmatig instelt op het Verzamelblad en de bestemming in bovestaande code wijzigt.
Daarom wil ik dus een loop om alle unieke waardes in kolom te bepalen en die unieke waardes verder te gebruiken in bovenstaande code.

Hopelijk nu iets duidelijker ?

Groet,

Jans

 

[Marrosi]

Hallo Jans,

Ik denk dat dit niet zo eenvoudig is met AUTOFILTER.

Ik heb echter iets in elkaar gezet gebaseerd op de ADVANCED FILTER.

Probeer volgende macro eens uit:

Sub TEST()
Dim RData As Range
Dim strName As String
Sheets("Verzamelblad").Range("J:J").Clear

Sheets("Verzamelblad").Activate
LRow = Cells.Find("*", Range("A1"), xlFormulas, , xlByRows, xlPrevious).Row
Range("A1:F" & LRow).Name = "MyData"

Set RData = Range("MyData")


RData.Columns(2).AdvancedFilter xlFilterCopy, , Sheets("Verzamelblad").Range("J1"), True


myLoop = Sheets("Verzamelblad").Range("J2", Sheets("Verzamelblad").Range("J65536").End(xlUp)).Rows.Count

For myCount = 1 To myLoop
strName = Sheets("Verzamelblad").Range("J2")

RData.AdvancedFilter xlFilterCopy, Sheets("Verzamelblad").Range("J1:J2"), Sheets(strName).Range("A65536").End(xlUp).Offset(1, 0)

Sheets("Verzamelblad").Range("J2").Delete
Next myCount

End Sub

Vriendelijke groeten - Marrosi

 

[jansbl]

Hallo Jans,

Ik denk dat dit niet zo eenvoudig is met AUTOFILTER.

Ik heb echter iets in elkaar gezet gebaseerd op de ADVANCED FILTER.

Probeer volgende macro eens uit:

enz. enz.

Vriendelijke groeten - Marrosi

Hallo Marrosi,

Het is (bijna) perfect.
Hartelijk dank.:thumb:
De macro copieerd goed naar de diverse sheets.
Er is 1 probleempje:
Op de sheet Noord worden ook de rijen met Noord-Oost en Noord-West gecopieerd.
Hetzelfde met Zuid. Daar worden ook de gegevens van Zuid-Oost en Zuid-West neergezet.

Ik heb gekeken in de help van advanced filter, maar ik heb niet kunnen achterhalen hoe kan worden ingesteld dat het criterium exact moet worden overgenomen.
Dus Noord alleen Noord en niet Noord-Oost en Noord-West.

Is dit in te stellen bij advance filter?

Met vriendelijke groet,

Jans

 

[Marrosi]

Hallo Jans,

Inderdaad ....stom dat ik daaraan niet heb gedacht

Probeer het onderstaande eens .... het is kunst-en-vliegwerk ... en ik heb het niet kunnen testen ....

Sub Test()
Dim RData As Range
Dim strName As String
Sheets("Verzamelblad").Range("J:J").Clear

Sheets("Verzamelblad").Activate
LRow = Cells.Find("*", Range("A1"), xlFormulas, , xlByRows, xlPrevious).Row
Range("A1:F" & LRow).Name = "MyData"

Set RData = Range("MyData")

RData.Columns(2).AdvancedFilter xlFilterCopy, , Sheets("Verzamelblad").Range("J1"), True

MyLoop = Sheets("Verzamelblad").Range("J2", Sheets("Verzamelblad").Range("J65536").End(xlUp)).Rows.Count
y = "=""="
Columns("K:K").NumberFormat = "0"
Range("K1") = "AREA"

For x = 2 To MyLoop + 1
Cells(x, 11) = y & Cells(x, 10).Value & """"
Next x
For myCount = 1 To MyLoop
strName = Sheets("Verzamelblad").Range("J2")

RData.AdvancedFilter xlFilterCopy, Sheets("Verzamelblad").Range("K1:K2"), Sheets(strName).Range("A65536").End(xlUp).Offset(1, 0)

Sheets("Verzamelblad").Range("J2:K2").Delete
Next myCount

End Sub

Vragen, opmerking of kommentaar zijn altijd welkom.

Vriendelijke groeten - Marrosi

 

[jansbl]

Hallo Jans,

Inderdaad ....stom dat ik daaraan niet heb gedacht

Probeer het onderstaande eens .... het is kunst-en-vliegwerk ... en ik heb het niet kunnen testen ....

Sub Test()
enz., enz..........
End Sub

Vragen, opmerking of kommentaar zijn altijd welkom.

Vriendelijke groeten - Marrosi

Hallo Marrossi,

In de gauwigheid gezien dat het lijkt te werken.
Bedankt. :thumb:

Ik wil vanavond nog even wat aanvullingen maken.
Dan kom ik vast weer wat tegen.
Ik laat het item nog maar even open dan.

Met vriendelijke groet,

Jans

 

[jansbl]

Hallo Marrosi,

Ik heb nog e.e.a. toegevoegd / gewijzigd.
Waarom?
Ik wil graag de inhoud v.d. cellen kopieren met opmaak en/of opmerkingen.
Of dat met advanced filter mogelijk is weet ik niet.
Maar ik heb met het autofilter voorbeeld (Sub CopyFilter) gemerkt dat de opmaak enz. wel behouden blijft.

Ik heb die sub wat aangepast en binnen jouw loop gezet.
Het schijnt te werken, maar aan mijn programmeerstijl zal vast veel te verbeteren zijn.

Verder heb ik een controle toegevoegd om te kunnen zien in welke rij cel(len) zijn gewijzigd.

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("b:g")) Is Nothing Then Exit Sub
Cells(Target.Row, "h") = Date
End Sub

Hieraan met voorwaardelijke opmaak ook nog een kleurtje gegeven.
De datums en kleurtje worden weer verwijderd, zodra de gegevens zijn gecopieerd van het verzamelblad naar de afzonderlijke bladen.

Ik heb het tevens zo ingesteld dat de afzonderlijke bladen eerst worden gewist, voordat er gegevens naar worden gekopieerd.

De code ziet er nu zo uit:

Sub Test3()
On Error Resume Next
Dim rng, rng2 As Range
Dim RData As Range, strName As String

Sheets("Verzamelblad").Activate
Sheets("Verzamelblad").Range("J:J").Clear
    
LRow = Cells.Find("*", Range("A1"), xlFormulas, , xlByRows, xlPrevious).Row
Range("A1:H" & LRow).Name = "MyData"

Set RData = Range("MyData")

RData.Columns(3).AdvancedFilter xlFilterCopy, , Sheets("Verzamelblad").Range("J1"), True
    
MyLoop = Sheets("Verzamelblad").Range("J2", Sheets("Verzamelblad").Range("J65536").End(xlUp)).Rows.Count
    
Range("A1:H1").Select
Selection.AutoFilter

For myCount = 1 To MyLoop
    strName = Sheets("Verzamelblad").Range("J" & myCount + 1)
    Selection.AutoFilter Field:=3, Criteria1:=strName
    
    With ActiveSheet.AutoFilter.Range
     On Error Resume Next
       Set rng2 = .Offset(1, 0).Resize(.Rows.Count - 1, 1) _
           .SpecialCells(xlCellTypeVisible)
     On Error GoTo 0
    End With
    If rng2 Is Nothing Then
           MsgBox "No data to copy"
        Else
           Worksheets(strName).Cells.Clear
           Set rng = ActiveSheet.AutoFilter.Range
           rng.Offset(0, 0).Resize(rng.Rows.Count).Copy _
           Destination:=Worksheets(strName).Range("A1")
    End If

Next myCount

Sheets("Verzamelblad").AutoFilterMode = False
Sheets("Verzamelblad").Range("J1:J" & LRow).Clear
Sheets("Verzamelblad").Range("H2:H" & LRow).Clear
Range("A1").Select
End Sub

Er moet waarschijnlijk nog veel aan worden verbeterd. In elk geval worden er nog wat functies aan toegevoegd.
Wordt vervolgd.
Bestandje toegevoegd.

Met vriendelijke groet,

Jans