Excel vba選擇自動篩選器下拉菜單中的下一個選項

Question

我有幾列有幾百行數據。我的角色之一是查看數據（最常見的是第2列），因此我所做的是單擊列標題上的小下拉箭頭以打開自動篩選器列表，取消選擇第一個值，然後選擇下一個值。然後，同樣，打開菜單，取消選擇第二個值並選擇第三個。

也沒有固定數量的值。不同的數據表有不同數量的數據。數據通常像0,10,40,50,60，......這是不固定的。但它是一個數組。所有的數據已經在增加。

我需要：

1. 優選地，按鈕點擊（列2）取消選擇當前所選的值，選擇下一個值和過濾器出
2. 相反的。即取消選擇當前值，選擇前值

從本質上講，我需要一個正向和回我的數據按鈕。

這是當我試圖記錄我的行爲時得到的結果。

Sub a() 

ActiveSheet.Range("$A$2:$V$609").AutoFilter Field:=2, Criteria1: 
    ="750385/000" 
    ActiveSheet.Range("$A$2:$V$609").AutoFilter Field:=2, Criteria1: 
    ="750385/010" 
ActiveSheet.Range("$A$2:$V$609").AutoFilter Field:=2, Criteria1: 
    ="750385/017" 

末次

感謝所有幫助！

Answer 1

我會做這樣的事情。

首先：獲取幫助列X，其中您複製列B中的所有唯一數據。

Option Explicit 

Sub CreateUniqueList() 
Dim lastrow As Long 

lastrow = Cells(Rows.Count, "B").End(xlUp).Row 

    ActiveSheet.Range("B1:B" & lastrow).AdvancedFilter _ 
    Action:=xlFilterCopy, _ 
    CopyToRange:=ActiveSheet.Range("X1"), _ 
    Unique:=True 
    ActiveSheet.Range("Y1").Value = "x" 
End Sub 

你的列表可以後，像這樣lokk：

之後，您將需要一個循環的按鈕：

這樣的事情。

//代碼不Testet //

Sub butNextValue() 
Dim lastrow As Long 

lastrow = Cells(Rows.Count, "B").End(xlUp).Row 


For i = 2 To lastrow 
    If ActiveSheet.Cells(i, 25).Value = "x" Then 
     If Not ActiveSheet.Cells(i+1, 24)-value = "" Then 'check if next value is there 
      ActiveSheet.Range("$A$2:$V$609").AutoFilter Field:=2, Criteria1:=ActiveSheet.Cells(i+1, 24)-value 
     Else 
      MsgBox "No more Next Values" 
     End If 
     Exit For 
    End If 
Next i 

End Sub 

Sub butPriValue() 
Dim lastrow As Long 

lastrow = Cells(Rows.Count, "B").End(xlUp).Row 


For i = 2 To lastrow 
    If ActiveSheet.Cells(i, 25).Value = "x" Then 
     If Not ActiveSheet.Cells(i-1, 24)-value = "Set" OR Not ActiveSheet.Cells(i-1, 24)-value = "" Then 'check if next value is there 
      ActiveSheet.Range("$A$2:$V$609").AutoFilter Field:=2, Criteria1:=ActiveSheet.Cells(i-1, 24) 
     Else 
      MsgBox "No more Pri Values" 
     End If 
     Exit For 
    End If 
Next i 

End Sub 

Answer 2

我會在紙張上使用Spinbuttons並將其鏈接到該列的第一個單元格，它要篩選。

（我把它叫做spbFilterChange並鏈接到$ B $ 1）

（圖片上傳不工作在這裏，抱歉）

然後你可以把下面的代碼工作表的模塊：

Private Sub spbFilterChange_SpinDown() 
    Change_Filter Me.Range(Me.spbFilterChange.LinkedCell), False 
End Sub 

Private Sub spbFilterChange_SpinUp() 
    Change_Filter Me.Range(Me.spbFilterChange.LinkedCell), True 
End Sub 

和標準模塊中以下子：

Option Explicit 

Sub Change_Filter(SortField As Range, Up As Boolean) 
Dim Filter_Values As Collection 
Dim Value_Arr, Val, Sort_Value As String 
Application.ScreenUpdating = False 
    ' Find Unique Values in relevant Column -> Collection 
    Set Filter_Values = New Collection 
    SortField.Offset(2, 0).Areas(1).AutoFilter SortField.Column 
    Value_Arr = SortField.Parent.Range(SortField.Offset(3, 0), SortField.Parent.Cells(SortField.Parent.Rows.Count, SortField.Column).End(xlUp)).Value2 
    On Error Resume Next 
    For Each Val In Value_Arr 
     Filter_Values.Add Val, CStr(Val) 
    Next Val 

    ' Check if Value of LinkedCell is in range 
    If SortField.Value < 1 Or SortField.Value > Filter_Values.Count Then SortField.Value = 1 

    ' set autofilter 
    Sort_Value = Filter_Values(SortField.Value) 
    SortField.Offset(2, 0).AutoFilter SortField.Column, Sort_Value 
Application.ScreenUpdating = True 
End Sub 

這應該解決您的問題，並且可以用於不同的列和工作表（您必須在工作表模塊中添加另一個事件過程的副本）。

Answer 3

有一種方法可以讀出curent過濾器，您可以通過該過濾器循環訪問該列，直到找到該值。在這裏你只需要跳到下一行的值，現在你可以把它放到過濾器中。

所以在最後這個方法是你的「前進」按鈕上

Sub test() 
    Dim startRow As Integer 
    startRow = 2 
    Dim rangeString As String 
    rangeString = "$A$2:$V$609" 


    Dim rng As Range 
    Set rng = Range(rangeString) 

    Dim currentCrit As String 
    currentCrit = rng.Parent.AutoFilter.Filters(2).Criteria1 
    currentCrit = Right(currentCrit, Len(currentCrit) - 1) 

    Dim i As Integer 
    For i = startRow To startRow + rng.Rows.Count 
     If Cells(i, 2).Value = currentCrit Then 
      i = i + 1 
      Exit For 
     End If 
    Next 

    If i > rng.Rows.Count + startRow Then 
     Exit Sub 
    End If 

    ActiveSheet.Range(rangeString).AutoFilter Field:=2, Criteria1:=Cells(i, 2).Value 
End Sub 

注：此不需額外的工作，如果有你在B列重複的，如果是這樣的更換部件用以下For循環：

Dim i As Integer 
Dim bool As Boolean 
bool = False 
For i = startRow To startRow + rng.Rows.Count 
    If Cells(i, 2).Value = currentCrit Then 
     bool = True 
    End If 

    If bool And Cells(i, 2).Value <> currentCrit Then 
     Exit For 
    End If 
Next 

希望我能幫上忙。