Поиск и сортировка диапазонов в Excel с помощью кнопок рычажных

Обновить

April 2019

Просмотры

58 раз

1

У меня есть электронная таблица, содержащую ± 100 названных диапазонов (5 строк, 15 colums), которые отсортированы по времени.

Мой план состоял в том, чтобы сделать кнопки переключения, чтобы скрыть или отобразить именованные диапазоны, если они содержат определенное значение.

Поэтому, когда я выбираю кнопку-переключатель для «Opel», например, отображаются все именованные диапазоны, содержащие «Opel». И когда я выбираю «Opel» и «Форд. Все диапазоны, содержащие «Opel» и «Форд» отображаются в то же время возможность сортировать диапазоны в этом представлении.

Для сортировки я использую следующий код:

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

Это прекрасно работает.

Но когда я использую его в сочетании с кнопками коленчатых он работает слишком медленно.

Для кнопок коленчатых я использую следующий код:

 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

Любые советы для ускорения этого процесса вверх?

0 ответы