çoklu toplama ve toplamı alınanların sayı numaralarını bulmak

[numb999]

merhabalar,
iki ayrı sutunda belli kritlerlere göre toplam almam ve aynı kriterlere göre toplamını aldığım hücrelerin tüm sayı numaralarını göstermek istiyorum. bunu yapmak mümkün müdür? ekte daha ayrıntılı anlattım.

saygılarımla.

 

[Necdet]

Merhaba,

Makro ile isterseniz aşağıdaki kodları bir modülle ilişkilendirip deneyiniz.

Sub Topla()
Dim j As Integer
Dim i, SonSatır As Long
Dim Tutar As Double
Dim Birim, Sayı As String
Set s1 = Sheets("Sayfa1")
s1.Select
Range("J2:K65000").ClearContents
Application.ScreenUpdating = False
For i = 2 To [A65536].End(3).Row
    For j = 1 To 2
    
        Sayı = Cells(i, "A")
        
        If j = 1 Then
            Birim = Trim(Cells(i, "B"))
            Tutar = Cells(i, "C")
        Else
            Birim = Trim(Cells(i, "D"))
            Tutar = Cells(i, "E")
        End If
        
        With Range("I2:I" & [I65536].End(3).Row)
            Set c = .Find(Birim, LookIn:=xlValues, LookAt:=xlPart)
            If Not c Is Nothing Then
                Cells(c.Row, "J") = Cells(c.Row, "J") + Tutar
                If Cells(c.Row, "K") = "" Then
                    Cells(c.Row, "K") = Sayı
                Else
                    Cells(c.Row, "K") = Cells(c.Row, "K") & ", " & Sayı
                End If
            End If
        End With
    Next j
Next i
Application.ScreenUpdating = True
MsgBox "İşlem Tamamdır...", vbOKOnly, "[URL="http://www.excel.web.tr/"]www.excel.web.tr[/URL]"
End Sub

 

[Ali]

Bence çok güzel olmuş,Necdet Bey. Ellerinize sağlık.

 

[Necdet]

Teşekkürler Ali bey.
Bakalım arkadaşımızın da işine yarayacak mı?

 

[numb999]

çok teşkkür ederim necdet hocam tam aradığım gibi olmuş. elinize sağlık.
keşke bende öğrenebilsem makroyu
daha sonra buraya farklı birimleri nasıl ekleyebilirim
saygılarımla.

 

[Necdet]

İyi akşamlar.

Kodlarda küçük bir değişiklikle Birimleri eklemeye de yazmaya da gerek kalmadan yapabiliriz.

Sub Topla()
Dim j As Integer
Dim i, SonSatır As Long
Dim Tutar As Double
Dim Birim, Sayı As String
Set s1 = Sheets("Sayfa1")
s1.Select
Application.ScreenUpdating = False
Range("I2:K65000").ClearContents

[B][COLOR=red]Range("B1:B" & [B65536].End(3).Row).Copy [L1]
Range("D2:D" & [D65536].End(3).Row).Copy Range("L" & [L65536].End(3).Row + 1)
Range("L:L").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("M1"), Unique:=True
Range("M2:M" & [M65536].End(3).Row).Copy [I2]
Columns("L:M").Delete[/COLOR][/B]
For i = 2 To [A65536].End(3).Row
    For j = 1 To 2
    
        Sayı = Cells(i, "A")
        
        If j = 1 Then
            Birim = Trim(Cells(i, "B"))
            Tutar = Cells(i, "C")
        Else
            Birim = Trim(Cells(i, "D"))
            Tutar = Cells(i, "E")
        End If
        
        With Range("I2:I" & [I65536].End(3).Row)
            Set c = .Find(Birim, LookIn:=xlValues, LookAt:=xlPart)
            If Not c Is Nothing Then
                Cells(c.Row, "J") = Cells(c.Row, "J") + Tutar
                If Cells(c.Row, "K") = "" Then
                    Cells(c.Row, "K") = Sayı
                Else
                    Cells(c.Row, "K") = Cells(c.Row, "K") & ", " & Sayı
                End If
            End If
        End With
    Next j
Next i
Application.ScreenUpdating = True
MsgBox "İşlem Tamamdır...", vbOKOnly, "[URL="http://www.excel.web.tr/"]www.excel.web.tr[/URL]"
End Sub

 

[numb999]

tekrar teşekkür ederim.
saygılarımla.

 

[numb999]

nejdet hocam merhaba,
biliyorum çok şey istedim ama son kez yardımıza ihtiyacım var. ekteki gibi sadece benim belirlediğim birimlerin verilerinin aktarılmasını istiyorum, bunu nasıl çözümleyebiliriz.
saygılarımla.