Stok koduna göre listelemek

[harakikiri]

Merhaba,

Ürün sayımında kullanmak istediğim bir çalışmaya ihtiyacım var.
3 Ayrı sayım yapılacak. Sonuçlar 3 ayrı sayfada toparlanacak. Ancak SAYIM sayfasında birleştirilecek. Şöyleki; stok kodu ve ürün adı tüm sayfadakiler alt alta sıralanırken, miktarlar ayrı ayrı karşılaştırılabilmek için uygun sütunlarda her alacaktır.
sayımlardaki ürün sayısı faklılıklar gösterebilir. yani birinde 1000 ürün sayılmışken diğerinde 1025 ürün sayılmış olabilir.

Daha iyi anlaşılabilmesi için bir örnek dosya ekliyorum.

Yardımcı olabilecek arkadaşlara teşekkür ederim.

 

[Orion1]

Dosyanız ektedir.

Option Base 1
Sub Urun_59()
'coder evrengizlen@hotmail.com
'Evren GİZLEN
Dim sh As Worksheet, myarr1(), myarr2(), list(), z As Object, sat As Long
Dim i As Long, k As Byte, n As Double, deg As String
myarr1 = Array("Sayfa1", "Sayfa2", "Sayfa3")
Application.ScreenUpdating = False
Sheets("SAYIM").Select
Range("A2:A65536").ClearContents
Set z = CreateObject("Scripting.Dictionary")
ReDim myarr2(1 To 5, 1 To 65536 * 3)
For k = 1 To 3
    Set sh = Sheets(myarr1(k))
    sat = sh.Cells(65536, "A").End(xlUp).Row
    If sat > 1 Then
        list = sh.Range("A2:C" & sat).Value
        For i = 1 To UBound(list)
            deg = list(i, 1) & list(i, 2)
            If Not z.exists(deg) Then
                n = n + 1
                z.Add deg, n
                myarr2(1, n) = list(i, 1)
                myarr2(2, n) = list(i, 2)
            End If
            myarr2(k + 2, z.Item(deg)) = myarr2(k + 2, z.Item(deg)) + list(i, 3)
        Next i
        Erase list()
    End If
Next k
Set z = Nothing
Set sh = Nothing
Erase myarr1()
If n > 65535 Then
    Application.ScreenUpdating = True
    MsgBox "Listelenen satır sayısı : " & UBound(myarr2, 2) & vbLf & "65535 ten fazla olduğu için taşama olacağı sebebi ile işlem iptal oldu", vbCritical, "U Y AR I"
    Erase myarr2()
    Else
    ReDim Preserve myarr2(5, n)
    Range("A2").Resize(n, 5) = Application.Transpose(myarr2)
    Application.ScreenUpdating = True
    Erase myarr2()
    MsgBox "İşlem tamalandı" & vbLf & "evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
End If
                
End Sub

 

[harakikiri]

Her yere yetişiyorsunuz
tekrar teşekkür ederim.