AccessTr.neT

bu da başka bir yöntem @feraz hocamın yardımlarıyla çok teşekkür ederim
tek farkı aradan 2. diziyi çıkarması

    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("Sheet1")

        .Range("A2:O" & Rows.Count).ClearContents

        With Me.ListView1

            sonLitview = .ListItems.Count

            If sonLitview = 0 Then GoTo var

            

            For i = 1 To sonLitview

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

                

                If Not dic.Exists(kriter) Then

                   dic.Add kriter, Array(.ListItems(i).ListSubItems(2), .ListItems(i).ListSubItems(3), .ListItems(i).ListSubItems(4), .ListItems(i).ListSubItems(5))

                    kr0 = dic.Item(kriter)(0)

                    kr1 = dic.Item(kriter)(1)

                Else



                    kr2 = CDbl(dic.Item(kriter)(2))

                    kr3 = CDbl(dic.Item(kriter)(3))

                    dic.Remove (kriter)

                    dic.Add kriter, Array(kr0, kr1, kr2 + .ListItems(i).ListSubItems(4), kr3 + .ListItems(i).ListSubItems(5))

                End If



            Next

        End With

            Range("B1").Resize(dic.Count, 4) = WorksheetFunction.Transpose(WorksheetFunction.Transpose(dic.Items))

            Range("A1").Resize(dic.Count, 1) = WorksheetFunction.Transpose(dic.keys)

    End With

    

var:

    On Error Resume Next

    Set dic = Nothing

    MsgBox "bitti"

yada

Dim dic As Object

      Dim i As Long, sonLitview As Long

    Dim kriter

    

    Set dic = CreateObject("Scripting.Dictionary")

    

    With ThisWorkbook.Sheets("Sheet1")

        .Range("A2:O" & Rows.Count).ClearContents

        With Me.ListView1

            sonLitview = .ListItems.Count

            If sonLitview = 0 Then GoTo var

            

            For i = 1 To sonLitview

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

                

                If Not dic.Exists(kriter) Then

                  dic.Add kriter, Array(.ListItems(i).ListSubItems(2), .ListItems(i).ListSubItems(3), .ListItems(i).ListSubItems(4), .ListItems(i).ListSubItems(5))

                    kr0 = dic.Item(kriter)(0)

                    kr1 = dic.Item(kriter)(1)

                Else

                    kr2 = CDbl(dic.Item(kriter)(2))

                    kr3 = CDbl(dic.Item(kriter)(3))

                    dic(kriter) = Array(kr0, kr1, CDbl(dic.Item(kriter)(2)) + .ListItems(i).ListSubItems(4), CDbl(dic.Item(kriter)(3)) + .ListItems(i).ListSubItems(5))

                End If





            Next

        End With

            Range("B1").Resize(dic.Count, 4) = WorksheetFunction.Transpose(WorksheetFunction.Transpose(dic.Items))

            Range("A1").Resize(dic.Count, 1) = WorksheetFunction.Transpose(dic.keys)

    End With



var:

    On Error Resume Next

    MsgBox "bitti"

    Set dic = Nothing

(30/12/2020, 02:16)berduş yazdı: [ -> ]WorksheetFunction.Transpose

Aslında bu 65536 satırdan sonrası için sapıtır
Bunsuz kodu ayarlamak gerekebilir büyük veriler için.Heralde verdiğim dosyada veriler böyleydi.Ayarlamaya çalışırım yada sizde yapabilirsiniz.Dediğim gibi transpose olayı 65536 satırdan fazla olunca tam çalışmıyor.

O zaman aklima gelmişken
1 - normal diziler en fazla ne kadar aliyor
2 - listviewin limiti ne? ben 32000 küsür satır diye okumuştum bir yerde bu durumda transpose sorun çıkarmamalı.

@feraz hocam @berduş hocam

ya ben size nidem he nidem gece gece neler yapmışsınız. Emeğinize ellerinize sağlık, iyiki varsınız.

Kodların hepsini tek tek denemedim ama arşivime kaydediyorum.. Kendi çalışmama uyarlamış olduğum @feraz hocamın koduna aşağıdaki ilaveyei yapmam yetti.

Hepinizden Allah razı olsun, sağlıklı huzurlu yıllar diliyorum.

rica ederim
İyi çalışmalar
mutlu yıllar