VBA Excel - 带有组合框的Userform过滤和写入 [英] VBA Excel - Userform with comboboxes filter down and write

问题描述

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

第一个过滤器是确定的，但我不知道如何去进一步我不能得到Autofilter工作在第二个过滤器...任何更好的解决方案？

下面的代码我有和表。

$ b pre> Private Sub UserForm_Initialize（）

Dim v，e，lastrow
lastrow = （Plan1）。单元格（Rows.Count，1）.End（xlUp）.Row
With Sheets（Plan1）。Range（A2：A& lastrow）
v =。值
结束于
使用CreateObject（scripting.dictionary）
.comparemode = 1
对于每个e In v
如果不是.exists（e）添加e，没有
下一个
如果.Count然后Me.cbBloco.List = Application.Transpose（.keys）
结束与

结束子


-

  BLOCK ACT标签状态
 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 
  

解决方案

after op's detailed specs
编辑2 ：OP的新规范后

在Form的模块中尝试

选项显式

Dim cnts（1到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（）

设置dbRng = Sheets ）.UsedRange
设置helperRng = dbRng.Offset（dbRng.Rows.Count + 1，dbRng.Columns.Count + 1）.Cells（1，1）
设置dataRng = dbRng.Offset ）.Resize（dbRng.Rows.Count - 1）
设置statusRng = dataRng.Columns（dbRng.Columns.Count）

使用Me
设置cnts（1）=。 cbBoco'< ==控制其实际名称
设置cnts（2）= .cbAct'< ==给出控制其实际名称
设置cnts（3）= .cbTag'给控制它的实际名称
结束与

调用FillComboBoxes

结束子


私有子FillComboBoxes（）
Dim i As Long

Application.ScreenUpdating = False

dbRng.Autofilter field：= 4，Criteria1：=<> ISSUED'&添加，以避免具有ISSUED状态的行

对于i = 1到UBound（cnts）

dataRng.SpecialCells（xlCellTypeVisible）.Columns（i） = helperRng

使用helperRng.CurrentRegion
如果.Rows.Count> 1 Then .RemoveDuplicates Columns：= Array（1），Header：= xlNo
使用.CurrentRegion
如果.Rows.Count> 1 Then
list（i）= Application.Transpose（.Cells）
Else
list（i）= Array（.Value）
End If
cnts ）.list = list（i）
.Clear
结束于
结束于

下一页i
Application.ScreenUpdating = True
b $ b End Sub


Private Sub ResetComboBoxes（）
Dim i As Long

FillComboBoxes'< == added。因为你不想显示ISSUED行，所有列表都必须重新填充
'For i = 1 To UBound（cnts）
'cnts（i）.list = list（i）
'cnts（i）.ListIndex = -1
'下一个i

结束子


私有子CbOK_Click b Dim i As Long

statusRng.ClearContents

With dbRng
dbRng.Autofilter field：= 4，Criteria1：=<> ISSUED'< ; ==添加，以避免具有ISSUED状态的行
对于i = 1到UBound（cnts）
.Autofilter字段：= i，Criteria1：= cnts（i）.Value
Next i

如果.SpecialCells（xlCellTypeVisible）.Cells.Count> .Columns.Count then
statusRng.SpecialCells（xlCellTypeVisible）.Value =ISSUED
否则
MsgBox无匹配
结束如果

。自动过滤器
dbRng.Autofilter字段：= 4，Criteria1：=<> ISSUED'< ==添加，以避免具有ISSUED状态的行
结束于

End Sub


私有子CbReset_Click（）
调用ResetComboBoxes
结束子


私有子cbAct_AfterUpdate（）
调用UpdateComboBoxes
结束子


私有子cbBloco_AfterUpdate（）
调用UpdateComboBoxes
结束子


Private Sub cbTag_AfterUpdate（）
调用UpdateComboBoxes
End Sub


Private Sub UpdateComboBoxes（）

Dim i As Long

使用dbRng
.Autofilter
dbRng.Autofilter字段：= 4，Criteria1：=<> ISSUED'< ==添加，以避免ISSUED status
For i = 1 To UBound（cnts）
如果cnts（i）.ListIndex> -1 Or cnts（i）.text<> 然后.Autofilter字段：= i，Criteria1：= cnts（i）.Value
Next i

如果.SpecialCells（xlCellTypeVisible）.Cells.Count> .Columns.Count then
Call RefillComboBoxes
Else
调用ClearComboBoxes
结束如果

.Autofilter
dbRng.Autofilter字段：= 4， Criteria1：=<> ISSUED'< ==添加，以避免具有ISSUED状态的行
结束于

结束子

b $ b 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
对于每个单元格在dataRng.Columns（i）.SpecialCells（xlCellTypeVisible）
helperRng.Offset（j）= cell.Value
j = j + 1
下一个单元格

使用helperRng.CurrentRegion
如果.Rows.Count> 1 Then .RemoveDuplicates Columns：= Array（1），Header：= xlNo
使用.CurrentRegion
如果.Rows.Count> 1 then
cnts（i）.list = Application.Transpose（.Cells）
Else
cnts（i）.list = Array（.Value）
End If
。清除
结束于
结束于
下一个i
Application.ScreenUpdating = True

结束子


Private Sub ClearComboBoxes（）

Dim i As Long

For i = 1到UBound（cnts）
cnts（i）.Clear
Next i

End Sub


I'm looking for some advise on this code. It is a UserForm with 3 comboboxes the first one filters the BLOCK (unique values), the second one the TAG (also unique) and the last it will be the ACT. After selecting all 3 we write the STATUS on the same line.

The first filter is ok, but I dont know how to go further I couldnt get Autofilter to work on the second filter... Any better solution?

Below the code I have and the table.

Thanks,

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

解决方案

edited after op's detailed specs edited 2: after OP's new specs

try this in Form's Module

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

这篇关于VBA Excel - 带有组合框的Userform过滤和写入的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！