Named ranges sorteren en weergeven op basis van woord dat erin voorkomt

[TommyVoet]

Ik heb een spreadsheet met named ranges die ik sorteer op uur.

Het sorteren lukt. Maar ik wil toggle buttons toevoegen waarmee ik de ranges kan weergeven op een bepaald woord dat in de ranges voorkomt.

Als er 'Ford' in voorkomt bvb, dan wil ik al die ranges zien. Maar ook als er meerdere opties geselecteerd zijn. Bvb: 'Opel', 'Ford' en 'Chevrolet. In deze selectie wil ik dan ook nog een kunnen sorteren als dat nodig zou zijn.

Niet makkelijk, voor mij toch niet

Om te sorteren gebruik ik volgende code:

Sub SorterenOpdrachten()

Dim Detail As Worksheet
Dim I As Long
Dim ListRng As Range
Dim LijstWks As Worksheet
Dim NamedRng As Name
Dim R As Long
Dim Rng As Range
Dim SortWks As Worksheet


'Worksheet declareren als variabele
Set Detail = Worksheets("detail")
Set LijstWks = Worksheets("LijstWks")
Set SortWks = Worksheets("SortWks")

'Startrij voor de lijst instellen = Rij 1 fungeert als "hoofding"
R = 2



 'Ranges naar lijst kopiëren - Opdracht en uur
  For Each NamedRng In ActiveWorkbook.Names



    LijstWks.Cells(R, 1) = NamedRng.Name
    LijstWks.Cells(R, 2) = NamedRng.RefersToRange.Cells(1, 2)
    R = R + 1
  Next NamedRng

 'Ranges sorteren in de lijst
  R = R - 1
  Set ListRng = LijstWks.Range("A2").Resize(R - 1, 2)
  ListRng.Sort Key1:=ListRng.Cells(1, 2), Order1:=xlAscending



   'Ranges kopiëren naar SortWks
    R = 1
    For I = 1 To ListRng.Rows.Count
      Set Rng = ActiveWorkbook.Names(ListRng.Cells(I, 1).Text).RefersToRange
        Rng.Copy
        SortWks.Cells(R, 1).PasteSpecial Paste:=xlPasteAll
      R = R + Rng.Rows.Count
    Next I

    'Opdrachten naar detail kopiëren
    R = 1
    Worksheets("SortWks").Range("A1:T499").Copy 
Worksheets("detail").Range("A5:T504")

Next intCounter
End Sub

Werkt prima. Maar om de ranges dan op woord te selecteren gebruik ik toggle buttons. In combinatie met het sorteren wordt dit veel te traag. (± 100 ranges)

Voor de toggle buttons gebruik ik volgende code:

Sub Tegels()

Dim nm As Name

For Each nm In Application.Names
Range(nm).EntireRow.Hidden = True
Next nm


If TglOpel Then
For Each nm In Application.Names
    If Application.CountIf(Range(nm), "*" & "Opel" & "*") Then 
Range(nm).EntireRow.Hidden = False
Next nm
End If

If TglChevrolet Then
For Each nm In Application.Names
    If Application.CountIf(Range(nm), "*" & "Chevrolet" & "*") Then 
Range(nm).EntireRow.Hidden = False
Next nm
End If

If TglFord Then
For Each nm In Application.Names
    If Application.CountIf(Range(nm), "*" & "Ford" & "*") Then 
 Range(nm).EntireRow.Hidden = False
Next nm
End If

If TglBuick Then
For Each nm In Application.Names
    If Application.CountIf(Range(nm), "*" & "Buick" & "*") Then 
Range(nm).EntireRow.Hidden = False
Next nm
End If

If TglDodge Then
For Each nm In Application.Names
    If Application.CountIf(Range(nm), "*" & "Dodge" & "*") Then 
Range(nm).EntireRow.Hidden = False
Next nm
End If


End Sub


Sub CheckTegels()

If TglOpel Then
Call Tegels
Exit Sub
Else
    If TglChevrolet Then
    Call Tegels
    Exit Sub
    Else
        If TglFord Then
        Call Tegels
        Exit Sub
        Else
            If TglBuick Then
            Call Tegels
            Exit Sub
            Else
                If TglDodge Then
                Call Tegels
                Exit Sub
                Else

                            Dim nm As Name

For Each nm In Application.Names
Range(nm).EntireRow.Hidden = False
Next nm


End If
End If
End If
End If
End If
End If
End If
End If
End Sub

Dit laatste zou ik dus eleganter willen oplossen als dat mogelijk is.

Alle tips zijn welkom! Ik maak vorderingen, maar nog altijd groen achter de oren wat VBA betreft

Mvg,

Tommy