Listview den Sayfaya aktarma

[öğrtm]

mrb
ekteki çalışmamda listview deki verilerimi sayfaya aktarıyorum
fakat 3 adet döngü kullandığım için müthiş bir yavaşlama var
bu yavaşlamayı kaldırabilmem için kodlarımda nasıl bir revizyona gitmeliyim
yardımlarınızı bekliyorum

Private Sub CommandButton1_Click()

Application.ScreenUpdating = False
For ss = 1 To 51 'Başlık için dönüyor
For sss = 1 To 50 'Ayrıntı için dönüyor
For i = 1 To Me.ListView1.ListItems.Count 'Sıra numarası için dönüyor


Sheets("Sayfa1").Cells(1, ss).Value = Me.ListView1.ColumnHeaders(ss) 'başlık

Sheets("Sayfa1").Cells(1 + i, 1).Value = Me.ListView1.ListItems(i) 'Sıra no

Sheets("Sayfa1").Cells(i + 1, 1 + sss).Value = Me.ListView1.ListItems(i).ListSubItems(sss) 'Sıra no

Next i, sss, ss
Application.ScreenUpdating = True

MsgBox "işlem tamam"

End Sub

 

[halit3]

bu kodu denermisiniz.

Private Sub CommandButton1_Click()
Range("A1:AY500").ClearContents
Application.ScreenUpdating = False
sat1 = Worksheets("Sayfa1").[A65536].End(3).Row + 1
For n = 1 To Val(ListView1.ColumnHeaders.Count)
Sheets("Sayfa1").Cells(1, n).Value = ListView1.ColumnHeaders 'başlık
Next
For r = 1 To ListView1.ListItems.Count
x = ListView1.ListItems(r)
Sheets("Sayfa1").Cells(sat1, 1).Value = x 'Sıra numarası için dönüyor
For i = 1 To ListView1.ColumnHeaders.Count - 1
Sheets("Sayfa1").Cells(sat1, i + 1).Value = ListView1.ListItems(r).ListSubItems(i).Text 'kayıt için
Next i
sat1 = sat1 + 1
Next r
Application.ScreenUpdating = True
MsgBox "işlem tamam"
End Sub

 

[halit3]

hata kodunu kaldırdım

On Error Resume Next

 

[Orion1]

Dosyanız ektedir.

Private Sub CommandButton1_Click()
Sheets("Sayfa1").Cells.ClearContents
Application.ScreenUpdating = False
For ss = 1 To 50 'Başlık için dönüyor
Sheets("Sayfa1").Cells(1, ss).Value = Me.ListView1.ColumnHeaders(ss) 'başlık
For i = 1 To Me.ListView1.ListItems.Count 'Sıra numarası için dönüyor
Sheets("Sayfa1").Cells(i + 1, 1).Value = Me.ListView1.ListItems(i) 'Sıra no
Sheets("Sayfa1").Cells(i + 1, ss + 1).Value = Me.ListView1.ListItems(i).ListSubItems(ss) 'Sıra no
Next i, ss
Sheets("Sayfa1").Cells(1, 51).Value = Me.ListView1.ColumnHeaders(51) 'başlık
Application.ScreenUpdating = True
MsgBox "işlem tamam"
End Sub

 

[öğrtm]

evren ve halit bey ilginiz için teşekkür ederim.
kodlar gayet hızlı iyi akşamlar

 

[öğrtm]

lw den seçilenleri sayfaya aktarma

mrb yukarıdaki çalışmama devam olarak lw seçim kutusu ekledim.yapmak istediğim sadece checkboxun işaretli olduğu verileri sayfaya aktarmak.bu iş için aşağıdaki kodları denedim.fakat olmadı.sorunun i olarak belirlediğim sütunda olduğunu düşünerek sut=2 diye bir sabit oluşturdum devamında sut=sut+1 şeklinde yaptım fakat bu defada döngü sayıları dolayısı ile sorunlar yaşadım.konuyla ilgili yardımlarınızı bekliyorum.örnek dosyam ektedir.

Sheets("Rapor").Cells.ClearContents
Application.ScreenUpdating = False

For ss = 2 To 7 'Başlık için dönüyor+
Sheets("Rapor").Cells(ss - 1, 1).Value = Me.ListView1.ColumnHeaders(ss)
Next ss

For i = 1 To Me.ListView1.ListItems.Count 'Sıra numarası için dönüyor

For sss = 2 To 6 'Ayrıntı için dönüyor

If Me.ListView1.ListItems(i).Checked = True Then
Sheets("Rapor").Cells(1, i).Value = Me.ListView1.ListItems(i).ListSubItems(1) 'Sıra no
Sheets("Rapor").Cells(sss, i).Value = Me.ListView1.ListItems(i).ListSubItems(sss) 'Ayrıntı

End If
Next sss, i
Application.ScreenUpdating = True
MsgBox "işlem tamamdır"

 

[halit3]

bu kodu denermisiniz.

Private Sub CommandButton1_Click()
Sheets("Rapor").Cells.ClearContents
Application.ScreenUpdating = False
sat = 2
For ss = 2 To 7 'Başlık için dönüyor+
Sheets("Rapor").Cells(ss - 1, 1).Value = Me.ListView1.ColumnHeaders(ss)
Next ss
For i = 1 To Me.ListView1.ListItems.Count 'Sıra numarası için dönüyor
If Me.ListView1.ListItems(i).Checked = True Then
For sss = 2 To 6 'Ayrıntı için dönüyor
Sheets("Rapor").Cells(1, sat).Value = Me.ListView1.ListItems(i).ListSubItems(1) 'Sıra no
Sheets("Rapor").Cells(sss, sat).Value = Me.ListView1.ListItems(i).ListSubItems(sss) 'Ayrıntı
Next sss
sat = sat + 1
End If
Next i
Application.ScreenUpdating = True

MsgBox "işlem tamamdır"
End Sub

 

[öğrtm]

halit bey çok teşekkür ederim.
kodları denedim ve doğru sonucu alıyorum.size iyi çalışmalar dilerim.

 

[halit3]

halit bey çok teşekkür ederim.
kodları denedim ve doğru sonucu alıyorum.size iyi çalışmalar dilerim.

teşekkürler
iyi çalışmalar

 

[kadirdilbaz]

Teşekkür çok işime yaradı

 

[halit3]

Teşekkür çok işime yaradı

İyi çalışmalar