Listbox dan sayfaya istenilen sutunları aktarma hk.

[kemal turan]

Merhaba,
veri tabanından listbox a 15 sutunlu verileri filtreleyip listbox da görebilyorum.
İsteğim listboxda görünen verilerin tamamını değil de istediğim sutunları "LİSTEGORUSME" sayfasında istediğim sutunlara aktarmak istiyorum.
ek teki kod ile yapmaya çalışyorum bir yerlerde hata var.
Yardımlarınız için teşekkür ediyorum.

Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Sheets("LISTEGORUSME").Range("A2:N" & Rows.Count).ClearContents
With ListBox1
    For i = 2 To .ListCount - 15
        Sheets("LISTEGORUSME").Range("D" & i).Value = .List(i, 5)
        Sheets("LISTEGORUSME").Range("F" & i).Value = .List(i, 6)
        Sheets("LISTEGORUSME").Range("G" & i).Value = .List(i, 7)
        Sheets("LISTEGORUSME").Range("H" & i).Value = .List(i, 8)
        Sheets("LISTEGORUSME").Range("M" & i).Value = .List(i, 9)
        Sheets("LISTEGORUSME").Range("L" & i).Value = .List(i, 10)
        Sheets("LISTEGORUSME").Range("E" & i).Value = .List(i, 11)
        Sheets("LISTEGORUSME").Range("I" & i).Value = .List(i, 12)
        Sheets("LISTEGORUSME").Range("J" & i).Value = .List(i, 13)
        Sheets("LISTEGORUSME").Range("K" & i).Value = .List(i, 14)
        Sheets("LISTEGORUSME").Range("N" & i).Value = .List(i, 15)
    Next i
End With
Application.ScreenUpdating = True
MsgBox "İşlem tamamlandı.", vbInformation, "BİLGİLENDİRME"
End Sub

Verleri bu şekide listbox a alıyorum.

Sub MUSTERIARAMA()
Application.ScreenUpdating = False
On Error Resume Next
Set S1 = Sheets("MUSTERIGORUSMELERI")
S1.AutoFilterMode = False
Dim a As Long, i As Long
    ReDim Dizial(1 To 16, 1 To 1)
  
    ListBox1.Clear
    For i = 2 To S1.Cells(Rows.Count, 1).End(3).Row
        If UCase(Replace(Replace(S1.Cells(i, "E"), "ı", "I"), "i", "İ")) Like _
        "*" & UCase(Replace(Replace(TextBox1, "ı", "I"), "i", "İ")) & "*" Then
           a = a + 1
        
       ReDim Preserve Dizial(1 To 16, 1 To a)
            
            Dizial(1, a) = Format(S1.Cells(i, "B"), "DD.MM.YYYY")
            Dizial(2, a) = S1.Cells(i, "C")
            Dizial(3, a) = S1.Cells(i, "D")
            Dizial(4, a) = S1.Cells(i, "E")
            Dizial(5, a) = S1.Cells(i, "F")
            Dizial(6, a) = S1.Cells(i, "G")
            Dizial(7, a) = Format(S1.Cells(i, "I"), "#,##0")
            Dizial(8, a) = Format(S1.Cells(i, "J"), "#,##0")
            Dizial(9, a) = Format(S1.Cells(i, "K"), "#,##0")
            Dizial(10, a) = Format(S1.Cells(i, "P"), "#,##0")
            Dizial(11, a) = Format(S1.Cells(i, "O"), "#,##0")
            Dizial(12, a) = Format(S1.Cells(i, "H"), "#,##0")
            Dizial(13, a) = Format(S1.Cells(i, "L"), "#,##0")
            Dizial(14, a) = Format(S1.Cells(i, "M"), "#,##0")
            Dizial(15, a) = Format(S1.Cells(i, "N"), "#,##0")
            Dizial(16, a) = Format(S1.Cells(i, "Q"), "#,##0")
        End If
    Next i
        ListBox1.Column = Dizial
    Erase Dizial
    a = Empty
    i = Empty
 
    Application.ScreenUpdating = True
End Sub

 

[Muzaffer Ali]

Merhaba.
Hatanın ne olduğunu da söyleseniz daha kolay çözüm bulunur.

Satırların tamamı gelmiyor onun dışında bir hata bulamadım.
Aşağıdaki kodu kullanın.

Private Sub CommandButton4_Click()
    Application.ScreenUpdating = False
    Sheets("LISTEGORUSME").Range("A2:N" & Rows.Count).ClearContents
    With lstFiltre
        For i = 2 To .ListCount - 15
            Sheets("LISTEGORUSME").Range("D" & i).Value = .List(i - 2, 5)
            Sheets("LISTEGORUSME").Range("F" & i).Value = .List(i - 2, 6)
            Sheets("LISTEGORUSME").Range("G" & i).Value = .List(i - 2, 7)
            Sheets("LISTEGORUSME").Range("H" & i).Value = .List(i - 2, 8)
            Sheets("LISTEGORUSME").Range("M" & i).Value = .List(i - 2, 9)
            Sheets("LISTEGORUSME").Range("L" & i).Value = .List(i - 2, 10)
            Sheets("LISTEGORUSME").Range("E" & i).Value = .List(i - 2, 11)
            Sheets("LISTEGORUSME").Range("I" & i).Value = .List(i - 2, 12)
            Sheets("LISTEGORUSME").Range("J" & i).Value = .List(i - 2, 13)
            Sheets("LISTEGORUSME").Range("K" & i).Value = .List(i - 2, 14)
            Sheets("LISTEGORUSME").Range("N" & i).Value = .List(i - 2, 15)
        Next i
    End With
    Application.ScreenUpdating = True
    MsgBox "İşlem tamamlandı.", vbInformation, "BİLGİLENDİRME"
End Sub

 

[kemal turan]

Muzaffer hocam
hiç veri gelmiyor. hata da vermiyor

 

[kemal turan]

bu satırda hata verdi

For i = 2 To .ListCount - 15

 

[kemal turan]

Muzaffer hocam merhaba
Yabancı bir siteden alıntı yapıp düzenlediğim aşağıdaki kod isteğimi gerçekleştirdi.
Tabiki ustalarımızın farklı çözümleride olacaktır.
Teşekkür ederim.

Private Sub CommandButton1_Click()
Application.ScreenUpdating = False

Sheets("LISTEGORUSME").Range("A2:N" & Rows.Count).ClearContents
Dim lItem As Long
  
    For lItem = 0 To ListBox1.ListCount - 1
        With Worksheets("LISTEGORUSME")
    
            Sheets("LISTEGORUSME").Cells(lItem + 2, 4) = ListBox1.List(lItem, 5)
            Sheets("LISTEGORUSME").Cells(lItem + 2, 5) = ListBox1.List(lItem, 6)
            Sheets("LISTEGORUSME").Cells(lItem + 2, 6) = ListBox1.List(lItem, 7)
            Sheets("LISTEGORUSME").Cells(lItem + 2, 7) = ListBox1.List(lItem, 8)
            Sheets("LISTEGORUSME").Cells(lItem + 2, 8) = ListBox1.List(lItem, 9)
        End With
    Next lItem
    Application.ScreenUpdating = True
    MsgBox "İşlem tamamlandı.", vbInformation, "BİLGİLENDİRME"

End Sub

 

[ynmcan]

merhaba,
Aşağıdaki kodu kullanabilirsiniz.
ancak sayfadaki sütun genişliklerini değiştirmemeniz gerekir
dosyanız ekte

For a = 1 To 23
deg = deg & ";" & Replace(Columns(a).Width, ",", ".")
Next
lstFiltre.ColumnCount = 23
lstFiltre.ColumnWidths = Right(deg, Len(deg) - 1)

 

[kemal turan]

Merhaba
Telefondan baktığım kadarı ile
Cevap benim soruma yönelik değil gibi.

 

[ynmcan]

Merhaba
Telefondan baktığım kadarı ile
Cevap benim soruma yönelik değil gibi.

Kusura bakmayın başka konunu ile alakalı cevabı size atmışsım