AccessTr.neT

Tam Versiyon: Listviewden Excele Aktarımda Sumıf Kullanımı
Şu anda arşiv modunu görüntülemektesiniz. Tam versiyonu görüntülemek için buraya tıklayınız.
Sayfalar: 1 2 3 4 5 6 7 8 9 10
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..
Sayfalar: 1 2 3 4 5 6 7 8 9 10