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

我將在工作表上使用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 2

有一種讀取當前過濾器的方法，從中可以循環遍歷該列，直到找到該值為止。 在這里，您只需要跳到下一行的值即可，現在可以將其放入過濾器中。

因此，總而言之，此方法將成為您的“前進”按鈕

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列中有重復項，則此方法將不起作用，如果是這樣，請使用以下內容將“替換為”部分替換為該部分：

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

希望我能幫上忙。

Answer 3

我會做這樣的事情。

首先：獲取幫助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

之后，您的列表可能會這樣：

之后，您需要為按鈕循環：

這樣的事情。

//代碼不是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