Koşula göre toplama

[unalh]

S.a Arkadaşlar,

Ekli dosyada yapmak istediğim iki işlem var.

1-Grup ve fiyatı aynı olanları topla
Burada öncelik grubu aynı olanlar sonrasında grubu aynı olanlar içersinde
fiyatı aynı olanların adetlerinin toplanması

2-Grubu aynı olanları topla
Burada grubu aynı olanların toplanmısı gerekiyor.


Ekte iki işlem içinde örnek hazırladım.

İlginize şimdiden teşekkür ederim.

 

[Orion1]

Dosyanız ektedir.

Option Base 1
Sub grubu_topla_59()
Dim z As Object, n As Long, i As Long, myarr()
Dim liste(), sat As Long, deg As String
Sheets("Sayfa1").Select
Range("H2:L65536").ClearContents
sat = Cells(65536, "E").End(xlUp).Row
If sat < 2 Then Exit Sub
ReDim myarr(1 To 6, 1 To sat)
Set z = CreateObject("Scripting.Dictionary")
liste = Range("A2:E" & sat)
For i = 1 To UBound(liste)
    deg = UCase(Replace(Replace(liste(i, 5), "ı", "I"), "i", "İ")) & _
    "-" & Format(liste(i, 4), "#,##0.00")
    If Not z.exists(deg) Then
        n = n + 1
        z.Add deg, n
        myarr(1, n) = liste(i, 1)
        myarr(2, n) = liste(i, 2)
        myarr(4, n) = liste(i, 4)
        myarr(5, n) = liste(i, 5)
    End If
    If IsNumeric(liste(i, 3)) Then myarr(3, z.Item(deg)) = myarr(3, z.Item(deg)) + liste(i, 3)
    myarr(6, z.Item(deg)) = myarr(6, z.Item(deg)) + 1
    If CLng(myarr(6, z.Item(deg))) > 1 Then myarr(1, z.Item(deg)) = ""
Next i
Erase liste
Application.ScreenUpdating = False
Range("H2").Resize(n, 5) = Application.Transpose(myarr)
Erase myarr
Set z = Nothing
'Range("A2:E" & sat).ClearContents
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlandı" & vbLf & "evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
    
End Sub

 

[unalh]

Evren hocam ilginize teşekkür ederim.

Dosya istediğimgibi olmuş.


Toplanan grupların kodlarını sildirme işlemi yapabilirmiyiz ?

 

[Orion1]

Evren hocam ilginize teşekkür ederim.

Dosya istediğimgibi olmuş.


Toplanan grupların kodlarını sildirme işlemi yapabilirmiyiz ?

dosayayı günceledim.
2 numaralı mesajdan indirebilirsiniz.

 

[unalh]

Evren hocam toplanan ürünlerin kodlarının silinmesi gerekiyor bunu nasıl yaparız

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodları denermisiniz.

Option Explicit
Sub GRUPLAYARAK_LİSTELE_1()
    Dim X As Long, Son_Satır As Long, Satır As Long, Say As Long
    Dim BUL As Range, ADRES As String
    
    Application.ScreenUpdating = False
    
    Sheets("Sayfa1").Select
    Range("H2:L65536").Clear
    Columns("AA:AC").Clear
    Son_Satır = Range("A65536").End(3).Row
    
    Columns("D:E").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("AA1"), Unique:=True
    With Range("AC2:AC" & Range("AA65536").End(3).Row)
        .Formula = "=SUMPRODUCT(($D$2:$D$" & Son_Satır & "=AA2)*($E$2:$E$" & Son_Satır & "=AB2))"
        .Value = .Value
    End With
    
    Satır = 2
    
    For X = 2 To Range("AA65536").End(3).Row
        Say = Evaluate("=SUMPRODUCT(($D$2:$D$" & Son_Satır & "=" & Cells(X, "AA").Address & ")*($E$2:$E$" & Son_Satır & "=" & Cells(X, "AB").Address & "))")
        If Say = 1 Then
            Cells(X, "AA").Copy Cells(Satır, "K")
            Cells(X, "AB").Copy Cells(Satır, "L")
            
            Set BUL = Range("E:E").Find(Cells(X, "AB"), LookAt:=xlWhole)
            If Not BUL Is Nothing Then
                ADRES = BUL.Address
                
                Do
                    If Cells(X, "AA") = BUL.Offset(0, -1) Then
                        Range("A" & BUL.Row & ":C" & BUL.Row).Copy Cells(Satır, "H")
                        Exit Do
                    End If
                Set BUL = Range("E:E").FindNext(BUL)
                Loop While Not BUL Is Nothing And BUL.Address <> ADRES
            End If
            Satır = Satır + 1
        
        Else
            Cells(X, "AA").Copy Cells(Satır, "K")
            Cells(X, "AB").Copy Cells(Satır, "L")
        
            Set BUL = Range("E:E").Find(Cells(X, "AB"), LookAt:=xlWhole)
            If Not BUL Is Nothing Then
                ADRES = BUL.Address
                
                Do
                    If Cells(X, "AA") = BUL.Offset(0, -1) Then
                        Range("B" & BUL.Row).Copy Cells(Satır, "I")
                        Exit Do
                    End If
                Set BUL = Range("E:E").FindNext(BUL)
                Loop While Not BUL Is Nothing And BUL.Address <> ADRES
            End If
            Cells(Satır, "J") = Evaluate("=SUMPRODUCT((D2:D" & Son_Satır & "=" & Cells(X, "AA").Address & ")*(E2:E" & Son_Satır & "=" & Cells(X, "AB").Address & ")*(C2:C" & Son_Satır & "))")
            Satır = Satır + 1
        End If
    Next
    Set BUL = Nothing
    Columns("AA:AC").Clear
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Sub GRUPLAYARAK_LİSTELE_2()
    Dim X As Long, Satır As Long, BUL As Range
    
    Application.ScreenUpdating = False
    
    Sheets("Sayfa1").Select
    Range("O2:R65536").Clear
    
    Columns("E:E").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("R1"), Unique:=True
    
    Satır = 2
    
    For X = 2 To Range("R65536").End(3).Row
        Set BUL = Range("E:E").Find(Cells(X, "R"), LookAt:=xlWhole)
        If Not BUL Is Nothing Then
            Range("B" & BUL.Row & ":D" & BUL.Row).Copy Cells(Satır, "O")
            Cells(X, "P") = WorksheetFunction.SumIf(Range("E:E"), Cells(X, "R"), Range("C:C"))
            Satır = Satır + 1
        End If
    Next
    Set BUL = Nothing
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[Orion1]

Evren hocam toplanan ürünlerin kodlarının silinmesi gerekiyor bunu nasıl yaparız

Dosyayı güncelledim.2 nolu mesajdan indirebilirisniz.
Ürün kodları H sütununda listeye dahil edilmedi.

 

[unalh]

Korhan hocam cevabınız içinde çok teşekkür ederim.
Birinci sorudaki kod mantığı istediğim gibi olmuş.
İkinci sorunun cevabı içinde ayrıyetten teşekkür ederim.
Ellerinize sağlık.
Hayırlı işler.

 

[unalh]

Evren hocam ilginize çok teşekkür ederim.
Hocam H sütunundaki kodları tam manasıyla silmemeliyiz sadece toplanan grubun kodlarını silmeliyiz. Yani oraya taşıdığımız tek kod altındaki verilerin kodları duracak grup olarak taşıdığımız verilerin kodları silinicek.
Diyer bir husus M sütununda #YOK diye bir ibare çıkıyor bu neden olmuşmaktadır.
Sizi gerçekten yordum.
Hayırlı işler.

 

[Orion1]

Dosyayı 2 nolu mesajda günceledim.

Evren hocam ilginize çok teşekkür ederim.
Hocam H sütunundaki kodları tam manasıyla silmemeliyiz sadece toplanan grubun kodlarını silmeliyiz. Yani oraya taşıdığımız tek kod altındaki verilerin kodları duracak grup olarak taşıdığımız verilerin kodları silinicek.
Diyer bir husus M sütununda #YOK diye bir ibare çıkıyor bu neden olmuşmaktadır.
Sizi gerçekten yordum.
Hayırlı işler.

 

[unalh]

Hocam çok teşekkür ederim.

Tam istediğim gibi oldu.

Hayırlı işler.

 

[Orion1]

Hocam çok teşekkür ederim.

Tam istediğim gibi oldu.

Hayırlı işler.

Rica ederim.
İyi çalışmalar.

 

[Orion1]

Merhaba,ekli dosyada uyruk dağılımı ve yaş dağılımları var.Yapmak istediğim aylara dağılmış olan uyarukların genel toplamını ve yaş dağılımını almak.Mesela Arnavutluk bir kaç ay içerisinde var,bunların yaş dağılım toplamlarını almak istiyorum.Rapor genel olarak tüm aylarda bulunan uyrukların toplamını verecek şekilde formülüze edilmeli.yardımlarınız için şimdiden teşekkür ederim

Konunuzu yeni bir başlık açarak sorunuz.