Otomatik süzden sonra Listbox1 e aktarma

[mrttrn]

16 satırlık listemde Otomatik süzme ile 5 satıra düşüyor.
otomatik süzmeden sonra geriye kalan 5 satırı
CurrentRegion.Copy ile başka sayfaya aktarıp Listbox1 e zaten aktarıyorum.
İstediğim ise süzülmüş sayfayı direkt Listbox1 e aktarmak.

 

[Orion1]

Ekli dosyayı inceleyiniz.
Listbox'ı 3 kolona göre düzenledim.

Private Sub UserForm_Initialize()
Dim a, i As Long, k As Byte
 Worksheets("Sayfa1").Select
 Range("A1").AutoFilter 2, "des" 'otomatik süz
 ListBox1.ColumnCount = 3
 ReDim myarr(1 To 3, 1 To 1)
 For i = 2 To Cells(65536, "A").End(xlUp).Row
    If Range("A" & i).EntireRow.Hidden = False Then
        a = a + 1
        ReDim Preserve myarr(1 To 3, 1 To a)
        For k = 1 To 3
            myarr(k, a) = Cells(i, k).Value
        Next k
    End If
Next i
ListBox1.Column = myarr
Erase myarr
''Range("A1").AutoFilter 'RAPOR otomatik süzmeyi kaldır.
End Sub

 

[Orion1]

Listbox'ı 3 kolona göre düzenledim.Önceki mesajımdan indirebilirsiniz.

 

[mrttrn]

Sn orion2 yardımınız için teşekkür ederim.

Ancak dikkatimi çeken bir nokta var otomatik süzmeden sonra son durumu
kopyalamaya yarayan CurrentRegion.Copy ile Sayfa2 ye aktarıp oradan Listbox1 e aktararak istediğimi zaten yapmıştım.
Sizin verdiğiniz kodda veri çok ise for döngüsü uzun sürebilir.
satır ve sutun sayısı çok olursa uzayabilir.

isteğim otomatik süzmeden sonra başka sayfaya kopyalama veya for ile değil
o an ki son durumu bir özel kodlama ile listbox1 e aktarmaktı.
İlgilendiğiniz için teşekkür ederim.