創建帶有過濾值的列​​表框excel

Question

我想在表格中過濾結果並用此結果創建列表框， 此代碼適用於表單上的列表框，但不適用於表單，任何想法？

Sub MyListBox() 

Dim rng As Range 
Dim vArr As Variant 
Dim ListBox1 As Object ---> this works on sheet but not works on form 

Dim x As Single 
Dim y As String 
y = Worksheets("Sheet2").Cells(1, 12).Value 
x = Worksheets("Sheet2").Cells(2, 12).Value 
Application.ScreenUpdating = False 
Application.EnableEvents = False 
Application.DisplayAlerts = False 

Set rng = Range("TestMaterial") 

Set ListBox1 = ActiveSheet.OLEObjects(1).Object ---> this works on sheet but not works on form 

rng.AutoFilter field:=13, Criteria1:=y 
rng.AutoFilter field:=12, Criteria1:=x 

Worksheets.Add 
rng.SpecialCells(xlCellTypeVisible).Copy Range("a1") 

vArr = ActiveSheet.UsedRange 

With ListBox1 
    .List = (vArr) 
End With 

ActiveSheet.Delete 
Worksheets("TRAINING").AutoFilterMode = False 
'rng.AutoFilter.Clear 


Application.ScreenUpdating = True 
Application.EnableEvents = True 
Application.DisplayAlerts = True 
End Sub 

我發現這個代碼，但這個創造了新的列表框，但不填充列表框與數據，只有標題，沒有找到什麼是不正確的，與此代碼我怎麼能彌補現有列表框？

Sub MyListBox() 
Dim rng As Range 
Dim vArr As Variant 

    Dim ListBox1 As MSForms.Control 
Application.ScreenUpdating = False 
Application.EnableEvents = False 
Application.DisplayAlerts = False 

Set rng = Range("TestMaterial") 
    Set ListBox1 = frmplan.Controls.Add("Forms.ListBox.1") ---> adds new Listbox to form even I have some one with name "Listbox1" 

rng.AutoFilter field:=13, Criteria1:=txtsdept.Value 
rng.AutoFilter field:=12, Criteria1:=txtsgrade 


Worksheets.Add 
rng.SpecialCells(xlCellTypeVisible).Copy Range("a1") 

vArr = ActiveSheet.UsedRange 

    With ListBox1 

    .List = (vArr) 
End With 

ActiveSheet.Delete 
Worksheets("TRAINING").AutoFilterMode = False 



Application.ScreenUpdating = True 
Application.EnableEvents = True 
Application.DisplayAlerts = True 
End Sub 

Answer 1

試試下面的代碼爲「用戶窗體」案：

Sub MyListBox() 
    With Range("TestMaterial") 
     .AutoFilter Field:=13, criteria1:=txtsdept.value 
     .AutoFilter Field:=12, criteria1:=txtsgrade 
     If Application.WorksheetFunction.Subtotal(103, .Resize(, 1)) > 1 Then FillListBox .SpecialCells(xlCellTypeVisible), Me.ListBox1 
     .Parent.AutoFilterMode = False 
    End With 
End Sub 

Sub FillListBox(filteredRng As Range, LB As msforms.ListBox) 
    Dim vArr As Variant 

    vArr = GetArray(filteredRng) '<--| fill array 
    With LB 
     .ColumnCount = UBound(vArr, 2) 
     .List = vArr 
    End With 
End Sub 

Function GetArray(filteredRng As Range) As Variant 
    Dim calculation As XlCalculation 

    ApplicationBoost True, calculation '<--| boost application "up" 
    With filteredRng 
     Worksheets.Add 
     .Copy Range("A1") 
     GetArray = ActiveSheet.UsedRange '<--| fill returned array 

     Application.DisplayAlerts = False '<--| disable alerts for what strictly needed 
     ActiveSheet.Delete 
     Application.DisplayAlerts = True '<--| enable alerts back 
    End With 
    ApplicationBoost False, calculation '<--| boost application "back"  
End Function 

Sub ApplicationBoost(boost As Boolean, calculation As XlCalculation) 
    With Application 
     If boost Then 
      calculation = .calculation '<--| retrieve current calculation setting 
      .calculation = xlCalculationManual '<--| turn calculation off 
     Else 
      .calculation = calculation '<--| restore current calculation setting 
     End If 
     .ScreenUpdating = Not boost 
     .EnableEvents = Not boost 
    End With 
End Sub 

，你可以看到，我重構你的代碼，並分成更小位，你可以更容易地處理兩者增強和維護您的代碼