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..