VBA Excel - Userform mit Comboboxen Filter nach unten und schreibe

Question

Ich bin auf der Suche nach etwas Beratung zu diesem Code. Es ist ein UserForm mit 3 Comboboxen, wobei der erste den BLOCK (eindeutige Werte), der zweite den TAG (auch einmalig) und der letzte den ACT filtert. Nachdem wir alle 3 ausgewählt haben, schreiben wir den STATUS in die selbe Zeile.

Der erste Filter ist in Ordnung, aber ich weiß nicht, wie man weiter geht Ich konnte Autofilter nicht auf dem zweiten Filter arbeiten ... Jede bessere Lösung?

Unter dem Code habe ich und die Tabelle.

Danke,

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

bearbeitet nach detaillierten Spezifikationen bearbeitet op 2: nach neuen Spezifikationen des OP

versuchen dieses Moduls in dem Formular

012.351.

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