(29/12/2020, 16:10)feraz yazdı: Soru listviewdeki veriler için değilmiydi.Ado ile yapılan Veritabanından veriye göre yapıyor.Normalde dictionary ile yaptığım olmalıydı.

@feraz hocam son hali bu, bunda karar kıldım. Ancak son dolu satırdan itibaren yazdırma işlemini beceremedim.

son=sayfa1.range("a65536").end (xlup).row+1 değişkeni tanımladım

arr(son,say, 2) = .ListItems(i).ListSubItems(2) olarak denedim hata verdi.

onu nasıl aşarım.

(29/12/2020, 17:47)kanakan52 yazdı:

(29/12/2020, 16:10)feraz yazdı: Soru listviewdeki veriler için değilmiydi.Ado ile yapılan Veritabanından veriye göre yapıyor.Normalde dictionary ile yaptığım olmalıydı.

Kod:

Dim dic As Object
    Dim say As Long
    Dim i As Long, sonLitview As Long
    Dim kriter, arr()
   
    Set dic = CreateObject("Scripting.Dictionary")
   
    With ThisWorkbook.Sheets("RAPOR")
        .Range("A2:S" & Rows.Count).ClearContents
        With Me.ListView1
            sonLitview = .ListItems.Count
            If sonLitview = 0 Then GoTo var
            ReDim arr(1 To sonLitview, 1 To 24)
           
            For i = 1 To sonLitview
                kriter = .ListItems(i)
                If Not dic.Exists(kriter) Then
                    son = Sayfa1.Range("A65536").End(xlUp).Row + 1
                    say = say + 1
                   
                    dic.Add kriter, say
                    arr(say, 1) = .ListItems(i)
                    arr(say, 2) = .ListItems(i).ListSubItems(2)
                    arr(say, 3) = .ListItems(i).ListSubItems(4)
                    arr(say, 4) = .ListItems(i).ListSubItems(14)
                    arr(say, 8) = .ListItems(i).ListSubItems(23)
                    arr(say, 9) = .ListItems(i).ListSubItems(13)
                    arr(say, 10) = .ListItems(i).ListSubItems(15)
                    arr(say, 11) = .ListItems(i).ListSubItems(16)
                    arr(say, 12) = .ListItems(i).ListSubItems(17)
                    arr(say, 13) = Replace(.ListItems(i).ListSubItems(18), " ", "")
                    arr(say, 14) = Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(.ListItems(i).ListSubItems(22), "A", ""), "B", ""), "C", ""), "Ç", ""), "D", ""), "E", ""), "F", ""), "G", ""), "H", ""), "I", ""), "İ", ""), "J", ""), "K", ""), "L", ""), "M", ""), "N", ""), "O", ""), "Ö", ""), "P", ""), "R", ""), "S", ""), "Ş", ""), "T", ""), "U", ""), "Ü", ""), "V", ""), "W", ""), "Y", ""), "Z", ""), "Q", ""), ":", "")
                   

                End If
                arr(dic(kriter), 5) = arr(dic(kriter), 5) + .ListItems(i).ListSubItems(11) + 0
               
            Next
        End With
     
        If say > 0 Then .Range("A2").Resize(say, UBound(arr, 2)).Value = arr
    End With
var:
    On Error Resume Next
    MsgBox "bitti"
    Set dic = Nothing
    Erase arr

@feraz hocam son hali bu, bunda karar kıldım. Ancak son dolu satırdan itibaren yazdırma işlemini beceremedim.

son=sayfa1.range("a65536").end (xlup).row+1  değişkeni tanımladım

arr(son,say, 2) = .ListItems(i).ListSubItems(2) olarak denedim hata verdi.

onu nasıl aşarım.

.Range("A2").Resize(say, UBound(arr, 2)).Value = arr

Yerine alttaki gibi deneyin,mobilden yazdım bilmiyorum çalışır mı?

.Range("A" & rows.count).end(3)(2,1).Resize(say, UBound(arr, 2)).Value = arr

(29/12/2020, 17:47)kanakan52 yazdı: arr(son,say, 2) = .ListItems(i).ListSubItems(2)

Burda tam olarak ne yapmak istediniz abey?

Berduş hocam içinize karışmak gibi olmasında alttaki yazdığını kodlarda 
gibi yerlerde deneme olanlar fazlalık bence yani kodu uzatıyor.
From deneme dendiği için zaten
olarak yazılsada olur.Access bildiğim kadarıyla otomatik yapıyor ordan yola çıkarak yapıyorsunuz galiba.
iki tablo ile sorgu yapılırken dediğiniz yöntem uygulanabilir bence.

haklısınız onlara gerek yok
zaten kodları tek tek yazmıyorum, accesse yaptırıp olduğu gibi excele aktarıyorum gerisi ufak tefek düzenlemeler o kadar.
excelde kod çalışırsa gerisine pek dokunmuyorum. Yani o kısımların olup olmaması çok da önemli değil tek tablolu sorgularda, birden fazla tablo olduğunda önemli oluyor o kısımlar en azından 2 tabloda da aynı isimde alanlar varsa.

Tamam abey.
Yapmışken birde collection ilede yapmış bulunayım örnek açısından.

Dim col As New Collection

Function Kolleksiyon_Varmi(ByVal deger As String) As Boolean

    On Error GoTo hata

    col.Add deger, deger

    Kolleksiyon_Varmi = False

    Exit Function

hata:

    Kolleksiyon_Varmi = True

End Function

Private Sub CommandButton1_Click()

    Dim say As Long

    Dim i As Long, sonLitview As Long

    Dim kriter, arr(), col2 As New Collection



    With ThisWorkbook.Sheets("Sheet1")

        .Range("A12:F" & Rows.Count).ClearContents

        With Me.ListView1

            sonLitview = .ListItems.Count

            If sonLitview = 0 Then GoTo var

            ReDim arr(1 To sonLitview, 1 To 6)

            For i = 1 To sonLitview

                kriter = .ListItems(i).ListSubItems(1)

                If Kolleksiyon_Varmi(kriter) = False Then

                    say = say + 1

                    col2.Add say, kriter

                    arr(say, 1) = .ListItems(i)

                    arr(say, 2) = .ListItems(i).ListSubItems(1)

                    arr(say, 3) = .ListItems(i).ListSubItems(2)

                    arr(say, 4) = .ListItems(i).ListSubItems(3)

                End If

                arr(col2(kriter), 5) = arr(col2(kriter), 5) + .ListItems(i).ListSubItems(4) + 0

                arr(col2(kriter), 6) = arr(col2(kriter), 6) + .ListItems(i).ListSubItems(5) + 0

            Next

        End With

        If say > 0 Then .Range("A12").Resize(say, UBound(arr, 2)).Value = arr

    End With

var:

    On Error Resume Next

    MsgBox "bitti"

    Set col = Nothing: Set col2 = Nothing

    Erase arr

End Sub