Değerli Hocalarım Merhaba,

Veritabanından Listview'e alınan veriyi etopla ile özet olarak excele aktarabilir miyiz? Biraz kafa yordum çıkamadım içinden?

Yardımlarınız için şimdiden teşekkür ederim.

yalnız şöyle bir sorun var: toplama işlemi Sipariş Noya göre yapılabilir ama mesela X0000000000001 nolu sipariş için 3 farlı firma ve stok adı var hangi firma ve stok adı yazılacak

Sonuç J:O aralığına gelir.Gerekärse ADO ilede yapılabilir.

Sub Etopla()



    Dim dic As Object

    Dim  say As Long

    Dim i As Long

    Dim kriter, arr()

    Dim sonSatir As Long

    

    Set dic = CreateObject("Scripting.Dictionary")

    

    With ThisWorkbook.Sheets("Sheet1")

        sonSatir = .Cells(Rows.Count, 1).End(3).Row

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

        If sonSatir < 2 Then GoTo var

        ReDim arr(1 To sonSatir, 1 To 6)

        

        For i = 2 To sonSatir

            kriter = .Cells(i, 2).Value

            If Not dic.Exists(kriter) Then

                say = say + 1

                dic.Add kriter, say

                arr(say, 1) = .Cells(i, 1).Value

                arr(say, 2) = .Cells(i, 2).Value

                arr(say, 3) = .Cells(i, 3).Value

                arr(say, 4) = .Cells(i, 4).Value

            End If

            arr(dic(kriter), 5) = arr(dic(kriter), 5) + .Cells(i, 5).Value

            arr(dic(kriter), 6) = arr(dic(kriter), 6) + .Cells(i, 6).Value

        Next

        If say > 0 Then .Range("J2").Resize(say, 6).Value = arr

    End With

var:

    MsgBox "bitti"

    Set dic = Nothing

    Erase arr

End Sub

Buda veri çoksa hızlı çalışması gerek.

Sub Etopla()

    Dim dic As Object

    Dim say As Long

    Dim i As Long

    Dim kriter, arr(), dizi

    Dim sonSatir As Long

    

    Set dic = CreateObject("Scripting.Dictionary")

    

    With ThisWorkbook.Sheets("Sheet1")

        sonSatir = .Cells(Rows.Count, 1).End(3).Row

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

        If sonSatir < 2 Then GoTo var

        dizi = .Range("A2:F" & sonSatir).Value

        ReDim arr(1 To sonSatir, 1 To 6)

        For i = 1 To UBound(dizi)

            kriter = CStr(dizi(i, 2))

            If Not dic.Exists(kriter) Then

                say = say + 1

                dic.Add kriter, say

                arr(say, 1) = dizi(i, 1)

                arr(say, 2) = dizi(i, 2)

                arr(say, 3) = dizi(i, 3)

                arr(say, 4) = dizi(i, 4)

            End If

            arr(dic(kriter), 5) = arr(dic(kriter), 5) + dizi(i, 5) + 0

            arr(dic(kriter), 6) = arr(dic(kriter), 6) + dizi(i, 6) + 0

        Next

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

    End With

var:

    On Error Resume Next

    MsgBox "bitti"

    Set dic = Nothing

    Erase arr: Erase dizi

End Sub

Buda Userformdaki butona tıklayınca listviewdeki verilerden toplar.

Private Sub CommandButton1_Click()

    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("J2:O" & 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 Not dic.Exists(kriter) Then

                    say = say + 1

                    dic.Add kriter, say

                    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(dic(kriter), 5) = arr(dic(kriter), 5) + .ListItems(i).ListSubItems(4) + 0

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

            Next

        End With

        If say > 0 Then .Range("J2").Resize(say, 6).Value = arr

    End With

var:

    On Error Resume Next

    MsgBox "bitti"

    Set dic = Nothing

    Erase arr

End Sub

(28/12/2020, 22:22)berduş yazdı: yalnız şöyle bir sorun var: toplama işlemi Sipariş Noya göre yapılabilir ama mesela X0000000000001  nolu sipariş için 3 farlı firma ve stok adı var hangi firma ve stok adı yazılacak

@berduş hocam selamlar,

Sadece sipariş numrasına göre toplam alıcak, firma ve stok adını görmezden gelecek.

---

@feraz hocam selamlar,

Tüm ilk fırsatta deneyip sonucu bildireceğim. Yine döktürmüşsün emeğine zihnine sağlık.

Selam ve dua ile..