VBA Excel-带有组合框的用户窗体可进行筛选和写入

Question

我正在寻找有关此代码的一些建议。它是一个有3个组合框的UserForm，第一个过滤BLOCK（唯一值），第二个过滤TAG（也是唯一的），最后一个将是ACT。在选择所有3个之后，我们在同一行上写入STATUS。

第一个过滤器还可以，但我不知道如何进一步。我无法让Autofilter在第二个过滤器上工作。。。有更好的解决方案吗？

下面是我的代码和表格。

谢谢，

Private Sub UserForm_Initialize()
    Dim v, e, lastrow
    lastrow = Sheets("Plan1").Cells(Rows.Count, 1).End(xlUp).Row
    With Sheets("Plan1").Range("A2:A" & lastrow)
        v = .Value
    End With
    With CreateObject("scripting.dictionary")
        .comparemode = 1
        For Each e In v
            If Not .exists(e) Then .Add e, Nothing
        Next
        If .Count Then Me.cbBloco.List = Application.Transpose(.keys)
    End With
End Sub

-

BLOCK        ACT    TAG          STATUS
M00          FAB    201-02-31
M00          MON    201-02-31
M02          FAB    201-02-32
M02          MON    201-02-32
M02          INS    201-02-32
M02          FAB    201-02-33
M02          MON    201-02-33
M02          INS    201-02-33
M02          TER    201-02-33

Answer 1

在操作的详细规范之后编辑 编辑2：在OP的新规格之后

在Form的模块中试试这个

Option Explicit
Dim cnts(1 To 3) As ComboBox
Dim list(1 To 3) As Variant
Dim dataRng As Range, dbRng As Range, statusRng As Range, helperRng As Range

Private Sub UserForm_Initialize()
Set dbRng = Sheets("Plan1").UsedRange
Set helperRng = dbRng.Offset(dbRng.Rows.Count + 1, dbRng.Columns.Count + 1).Cells(1, 1)
Set dataRng = dbRng.Offset(1).Resize(dbRng.Rows.Count - 1)
Set statusRng = dataRng.Columns(dbRng.Columns.Count)
With Me
    Set cnts(1) = .cbBloco '<== give control its actual name
    Set cnts(2) = .cbAct '<== give control its actual name
    Set cnts(3) = .cbTag '<== give control its actual name
End With
Call FillComboBoxes
End Sub

Private Sub FillComboBoxes()
Dim i As Long
Application.ScreenUpdating = False
dbRng.Autofilter field:=4, Criteria1:="<>ISSUED" ' <== added, to avoid rows with "ISSUED" status
For i = 1 To UBound(cnts)
    dataRng.SpecialCells(xlCellTypeVisible).Columns(i).Copy Destination:=helperRng
    With helperRng.CurrentRegion
        If .Rows.Count > 1 Then .RemoveDuplicates Columns:=Array(1), Header:=xlNo
        With .CurrentRegion
            If .Rows.Count > 1 Then
                list(i) = Application.Transpose(.Cells)
            Else
                list(i) = Array(.Value)
            End If
            cnts(i).list = list(i)
            .Clear
        End With
    End With
Next i
Application.ScreenUpdating = True
End Sub

Private Sub ResetComboBoxes()
Dim i As Long
FillComboBoxes '<== added. since you don't want "ISSUED" rows to be shown, all lists must be refilled
'For i = 1 To UBound(cnts)
'    cnts(i).list = list(i)
'    cnts(i).ListIndex = -1
'Next i
End Sub

Private Sub CbOK_Click()
Dim i As Long
statusRng.ClearContents
With dbRng
    dbRng.Autofilter field:=4, Criteria1:="<>ISSUED" ' <== added, to avoid rows with "ISSUED" status
    For i = 1 To UBound(cnts)
        .Autofilter field:=i, Criteria1:=cnts(i).Value
    Next i
    If .SpecialCells(xlCellTypeVisible).Cells.Count > .Columns.Count Then
        statusRng.SpecialCells(xlCellTypeVisible).Value = "ISSUED"
    Else
        MsgBox "No Match"
    End If
    .Autofilter
    dbRng.Autofilter field:=4, Criteria1:="<>ISSUED" ' <== added, to avoid rows with "ISSUED" status
End With
End Sub

Private Sub CbReset_Click()
Call ResetComboBoxes
End Sub

Private Sub cbAct_AfterUpdate()
    Call UpdateComboBoxes
End Sub

Private Sub cbBloco_AfterUpdate()
    Call UpdateComboBoxes
End Sub

Private Sub cbTag_AfterUpdate()
    Call UpdateComboBoxes
End Sub

Private Sub UpdateComboBoxes()
Dim i As Long
With dbRng
    .Autofilter
    dbRng.Autofilter field:=4, Criteria1:="<>ISSUED" ' <== added, to avoid rows with "ISSUED" status
    For i = 1 To UBound(cnts)
        If cnts(i).ListIndex > -1 Or cnts(i).text <> "" Then .Autofilter field:=i, Criteria1:=cnts(i).Value
    Next i
    If .SpecialCells(xlCellTypeVisible).Cells.Count > .Columns.Count Then
        Call RefillComboBoxes
    Else
        Call ClearComboBoxes
    End If
    .Autofilter
    dbRng.Autofilter field:=4, Criteria1:="<>ISSUED" ' <== added, to avoid rows with "ISSUED" status
End With
End Sub

Private Sub RefillComboBoxes()
Dim i As Long, j As Long
Dim cell As Range
Application.ScreenUpdating = False
For i = 1 To UBound(cnts)
    j = 0
    For Each cell In dataRng.Columns(i).SpecialCells(xlCellTypeVisible)
        helperRng.Offset(j) = cell.Value
        j = j + 1
    Next cell
    With helperRng.CurrentRegion
        If .Rows.Count > 1 Then .RemoveDuplicates Columns:=Array(1), Header:=xlNo
        With .CurrentRegion
            If .Rows.Count > 1 Then
                cnts(i).list = Application.Transpose(.Cells)
            Else
                cnts(i).list = Array(.Value)
            End If
            .Clear
        End With
    End With
Next i
Application.ScreenUpdating = True
End Sub

Private Sub ClearComboBoxes()
Dim i As Long
For i = 1 To UBound(cnts)
    cnts(i).Clear
Next i
End Sub