Süzülüp Alt Toplamlarının alınması hakkında...

[manly]

"K" sütunundaki SİPARİŞ DURUMUNA göre süzüldükten sonra, "B" sütunundaki STOK NO daki her stok numaranın "F" sütunundaki MİKTARLARIN toplanmış halini diğer bir sayfada istiyorum....

SONUÇ sayfasındaki gibi olmasını istiyorum.. Makro ile bunu halledebilir miyiz? Çeşit ve veri çok olduğu için makro istiyorum.. Yardım ederseniz sevinirim...

 

[manly]

Hocalarım yardımlarınızı bekliyorum....

 

[Orion1]

Dosyanız ektedir.

Option Base 1
Sub raptiye_rap_rap_59()
'Coder : evrengizlen@hotmail.com
Dim myarr(), list(), n As Long, z As Object, sat As Long, i As Long, k As Byte
Dim deg As String
Sheets("SONUÇ").Select
Application.ScreenUpdating = False
Range("B2:N65536").ClearContents
If Sheets("SONUÇ").AutoFilterMode = True Then Sheets("SONUÇ").AutoFilterMode = False
sat = Sheets("VERİ").Cells(65536, "B").End(xlUp).Row
If sat < 2 Then GoTo son
list = Sheets("VERİ").Range("B2:N" & sat).Value
ReDim myarr(1 To 13, 1 To UBound(list))
Set z = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(list)
    deg = list(i, 1) & "-" & list(i, 10)
    deg = UCase(Replace(Replace(deg, "i", "İ"), "ı", "I"))
    If Not z.exists(deg) Then
        n = n + 1
        z.Add deg, n
        For k = 1 To 13
            myarr(k, n) = list(i, k)
        Next k
        myarr(5, n) = 0
    End If
    myarr(5, z.Item(deg)) = myarr(5, z.Item(deg)) + list(i, 5)
Next i
Erase list(): Set z = Nothing
Range("B2").Resize(n, 13) = Application.Transpose(myarr)
Erase myarr()
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlandı" & vbLf & "evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
Exit Sub
son:
Application.ScreenUpdating = True
MsgBox "VERİ sayfasında veri yok", vbCritical, "UYARI"
End Sub

 

[manly]

Evren hocam çok teşekkürler, ellerinize sağlık...

 

[Orion1]

Evren hocam çok teşekkürler, ellerinize sağlık...

Rica ederim.

 

[manly]

Değişik bir dosyada denedim ama hata veriyor....

 

[manly]

Evren hocam gönderdiğim dosyayı yukarıdakine uygun bir kod yazar mısınız?...Ben o kadar uğraştım ama hep hata verdi....

 

[manly]

Evren hocam yardımlarınızı bekliyorum...

 

[manly]

Evren hocam bu kod çözdü sanırım....


Option Base 1
Sub dene()
'Coder : evrengizlen@hotmail.com
Dim myarr(), list(), n As Long, z As Object, sat As Long, i As Long, k As Byte
Dim deg As String
Sheets("SONUÇ").Select
Application.ScreenUpdating = False
Range("C2:W65536").ClearContents
If Sheets("SONUÇ").AutoFilterMode = True Then Sheets("SONUÇ").AutoFilterMode = False
sat = Sheets("VERİ").Cells(65536, "C").End(xlUp).Row
If sat < 2 Then GoTo son
list = Sheets("VERİ").Range("C2:W" & sat).Value
ReDim myarr(1 To 21, 1 To UBound(list))
Set z = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(list)
deg = list(i, 1) & "-" & list(i, 10)
deg = UCase(Replace(Replace(deg, "i", "İ"), "ı", "I"))
If Not z.exists(deg) Then
n = n + 1
z.Add deg, n
For k = 1 To 21
myarr(k, n) = list(i, k)
Next k
myarr(5, n) = 0
End If
myarr(5, z.Item(deg)) = myarr(5, z.Item(deg)) + list(i, 5)
Next i
Erase list(): Set z = Nothing
Range("C2").Resize(n, 21) = Application.Transpose(myarr)
Erase myarr()
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlandı" & vbLf & "evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
Exit Sub
son:
Application.ScreenUpdating = True
MsgBox "VERİ sayfasında veri yok", vbCritical, "UYARI"
End Sub

 

[Orion1]

Olduysa problem yok.
Tebrik ederim.
Online gözüküyorum ama devamlı bakamıtyorum foruma
Onun için göremedim sorunuzu.
Bu sıralar işler sıkı.
Bakamıyorum.
İyi çalışmalar.