Filtrelenmiş alanı ListBox'a aktarmak

[excellcan]

Forumda emeği geçen herkese merhaba. Arkadaşlar
(Sayfa1.Range("Z30:AW65536")) aralığında filtrelenmiş bir alanı ListBox7 ye nasıl aktarabilirim ? ListBox bilgileri aşağıda. İlgilenen arkadaşlara şimdiden teşekkürler.


ListBox7.ColumnCount = 26
ListBox7.RowSource = "Sayfa1!Z30:AW" & Cells(65536, "Z").End(3).Row
ListBox7.ColumnWidths = "30;70;90;150;40;40;40;40;40;40;40;40;0;0;0;0;40;0;40;40;40;40;40;40;40;40;40"

 

[Korhan Ayhan]

Merhaba,

Aşağıdaki kodu kendinize göre uyarlayınız.

Private Sub CommandButton1_Click()
    Dim S1, X, Say, Satir
 
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
 
    ListBox7.ColumnCount = 24
    ListBox7.ColumnWidths = "30;70;90;150;40;40;40;40;40;40;40;40;0;0;0;0;40;0;40;40;40;40;40;40"
    ListBox7.RowSource = ""
    ListBox7.Clear
 
    Set S1 = Sheets("Sayfa1")
 
    Satir = S1.Cells(Rows.Count, "Z").End(3).Row
 
    ReDim Dizi(1 To 24, 1 To 1)
 
    For X = 30 To Satir
        If S1.Rows(X).RowHeight <> 0 And S1.Cells(X, "Z") <> "" Then
            Say = Say + 1
            ReDim Preserve Dizi(1 To 24, 1 To Say)
            For Y = 26 To 49
                Dizi(Y - 25, Say) = S1.Cells(X, Y)
            Next
        End If
    Next
 
    If Say > 0 Then ListBox7.Column = Dizi
 
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

 

[excellcan]

Merhaba,

Aşağıdaki kodu kendinize göre uyarlayınız.

Private Sub CommandButton1_Click()
    Dim S1, Veri, X, Say, Satir
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    ListBox7.ColumnCount = 24
    ListBox7.ColumnWidths = "30;70;90;150;40;40;40;40;40;40;40;40;0;0;0;0;40;0;40;40;40;40;40;40"
    ListBox7.RowSource = ""
    ListBox7.Clear
    
    Set S1 = Sheets("Sayfa1")
    
    Satir = S1.Cells(Rows.Count, "Z").End(3).Row
    
    Veri = S1.Range("Z30:AW" & Satir).Value
    ReDim Dizi(1 To 24, 1 To 1)
        
    For X = 30 To Satir
        If S1.Rows(X).RowHeight <> 0 And S1.Cells(X, "Z") <> "" Then
            Say = Say + 1
            ReDim Preserve Dizi(1 To 24, 1 To Say)
            For Y = 26 To 49
                Dizi(Y - 25, Say) = S1.Cells(X, Y)
            Next
        End If
    Next
    
    If Say > 0 Then ListBox7.Column = Dizi
 
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

Hocam kodları denemeye ancak fırsatım oldu. Emeğinize sağlık. Teşekkürler.

 

[Korhan Ayhan]

Merhaba,

Önerdiğim kodda "Veri" tanımlamasını fazladan kullanmışım. Düzelttim. Son halini kullanınız...

 

[excellcan]

Korhan hocam 30.satırdaki sütun başlıklarını ListBox7.ColumnHeads = True yapmaya çalışıyorum ama beceremedim. Hocam bu yöntemle mümkün müdür . İlginiz için tekrar teşekkürler.