Создать список с отфильтрованным значением vba excel

Question

Я хотел бы отфильтровать результаты на листе и создать Listbox с этим результатом, этот код работает на listbox на листе, но не работает над формой, любой идеей?

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 

Я нашел этот код, но это создает новый ListBox, но не заполнять список с данными, только заголовки, не смогли найти то, что неправильно и как я могу заполнить существующий ListBox с этим кодом?

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

попробуйте следующий код для случая «UserForm»:

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 

, как вы можете видеть, я переработан код и раскол в более маленькие кусочки вы можете легко обрабатывать и как улучшить и поддерживать ваш код