VBA Excel-带组合框的用户窗体向下过滤并写入
我正在寻找一些关于这个代码的建议。它是一个带有3个组合框的用户表单。第一个组合框过滤块(唯一值),第二个组合框过滤标记(也是唯一的),最后一个组合框是ACT。选择所有3个后,我们将状态写入同一行 第一个过滤器还可以,但我不知道如何进一步我无法让自动过滤器在第二个过滤器上工作。。。有更好的解决办法吗 下面是我的代码和表格 谢谢VBA Excel-带组合框的用户窗体向下过滤并写入,excel,vba,combobox,populate,Excel,Vba,Combobox,Populate,我正在寻找一些关于这个代码的建议。它是一个带有3个组合框的用户表单。第一个组合框过滤块(唯一值),第二个组合框过滤标记(也是唯一的),最后一个组合框是ACT。选择所有3个后,我们将状态写入同一行 第一个过滤器还可以,但我不知道如何进一步我无法让自动过滤器在第二个过滤器上工作。。。有更好的解决办法吗 下面是我的代码和表格 谢谢 Private Sub UserForm_Initialize() Dim v, e, lastrow lastrow = Sheets("Plan1")
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
-
在op的详细规格之后编辑 编辑2:在OP的新规格之后 在表单的模块中尝试此操作
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
选项显式
作为组合框的Dim CNT(1到3)
尺寸列表(1至3)作为变型
Dim dataRng As Range、dbRng As Range、STATUS RNG As Range、helperRng As Range
私有子用户表单_初始化()
设置dbRng=图纸(“平面1”)。使用图纸
设置helperRng=dbRng.Offset(dbRng.Rows.Count+1,dbRng.Columns.Count+1)。单元格(1,1)
设置dataRng=dbRng.Offset(1)。调整大小(dbRng.Rows.Count-1)
设置statusRng=dataRng.Columns(dbRng.Columns.Count)
和我一起
设置cnts(1)=.cbBloco'.Columns.Count然后
调用重新填充组合框
其他的
调用ClearComboBox
如果结束
.自动过滤器
dbRng.Autofilter字段:=4,准则1:=“已发布”1,然后。RemovedUpplicates列:=Array(1),标头:=xlNo
带.CurrentRegion
如果.Rows.Count>1,则
cnts(i).list=Application.Transpose(.Cells)
其他的
cnts(i).list=数组(.Value)
如果结束
清楚的
以
以
接下来我
Application.ScreenUpdating=True
端接头
私有子ClearComboBox()
我想我会坚持多久
对于i=1至UBound(碳纳米管)
碳纳米管(i).透明
接下来我
端接头
但实际上我需要cbBloco是唯一的值,然后cbTags只显示cbBloco.value的值,cbAct显示cbTag.value的值。相反,RemovedUpplicates有没有办法过滤这些值然后复制它?太棒了!我只是想弄清楚发生了什么,把状态写在搜索行的正确地址上。非常感谢用户3598756!很高兴能帮上忙。如果我回答了你的问题,请记下我的答案。谢谢你用户3598756,你能再帮我一次吗?此组合选择用于向某人发送任务并保留其记录。想象一下,我选择了M02块,动作插入,标签201-02-32,然后发布这个。下次我发布另一个任务时,该组合将不再作为选项出现。如何执行?是要从dataRng中删除已发布的任务,以便用户无法再选择它,还是要在允许用户选择它的同时,简单地跟踪它以供将来的任务检查?
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