E Topla Hakkında

[konas06]

Herkese selam.
Firma isimleri ve tutarlarının olduğu iki sütunluk bir tablo var. Bu tabloyu 2.sayfada firma isimleri bazında adet ve tutar toplamı almak istiyoruz.
Konu hakkında yardımlarınızı bekliyoruz.
Yardımlarınız için şimdiden çok teşekkürler.

 

[Huseyinkis]

Herkese selam.
Firma isimleri ve tutarlarının olduğu iki sütunluk bir tablo var. Bu tabloyu 2.sayfada firma isimleri bazında adet ve tutar toplamı almak istiyoruz.
Konu hakkında yardımlarınızı bekliyoruz.
Yardımlarınız için şimdiden çok teşekkürler.

Verileriniz Firma bazında sıralayıp Veri / Alt Toplam Yardımı ile ekteki gibi yapabilirsiniz.

 

[useful]

bu şekilde olabilir

Herkese selam.
Firma isimleri ve tutarlarının olduğu iki sütunluk bir tablo var. Bu tabloyu 2.sayfada firma isimleri bazında adet ve tutar toplamı almak istiyoruz.
Konu hakkında yardımlarınızı bekliyoruz.
Yardımlarınız için şimdiden çok teşekkürler.

iyi çalışmalar...

 

[Korhan Ayhan]

Selamlar,

Sorunuzu makrolar bölümüne sorduğunuz için bende makrolu çözüm hazılramıştım.

3. Alternatif olarak ekteki örnek dosyayı incelermisiniz.

Uygulanan kod;

Option Explicit
 
Sub GRUPLAYARAK_AKTAR()
    Dim S1 As Worksheet, S2 As Worksheet, SAY As Integer, TOPLAM As Double
    Dim X As Long, SATIR As Long, BUL As Range, ADRES As String
    
    Set S1 = Sheets("ilk hali")
    Set S2 = Sheets("Sayfa2")
    
    S1.Range("D5:D65536").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=S1.Range("IV1"), Unique:=True
    S1.Columns("IV:IV").Sort Key1:=S1.Range("IV1"), Order1:=xlAscending, Header:=xlGuess, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
    
    S2.Range("A:B").Clear
    S2.Range("A1") = "FİRMA ADI"
    S2.Range("A1").Font.Bold = True
    S2.Range("B1") = "TUTAR"
    S2.Range("B1").Font.Bold = True
    SATIR = 2
    
    For X = 2 To S1.Range("IV65536").End(3).Row
        Set BUL = S1.Range("D:D").Find(S1.Cells(X, "IV"), , , xlWhole)
        If Not BUL Is Nothing Then
            ADRES = BUL.Address
            Do
            S2.Cells(SATIR, "A") = S1.Cells(X, "IV")
            S2.Cells(SATIR, "B") = BUL.Offset(0, 1)
            TOPLAM = TOPLAM + BUL.Offset(0, 1)
            SATIR = SATIR + 1
            SAY = SAY + 1
            Set BUL = S1.Range("D:D").FindNext(BUL)
            Loop While Not BUL Is Nothing And BUL.Address <> ADRES
        End If
        
        S2.Cells(SATIR, "A") = SAY & " Adet"
        S2.Cells(SATIR, "A").Font.Bold = True
        S2.Cells(SATIR, "A").Interior.ColorIndex = 6
        
        S2.Cells(SATIR, "B") = TOPLAM
        S2.Cells(SATIR, "B").Font.Bold = True
        S2.Cells(SATIR, "B").Interior.ColorIndex = 6
        
        TOPLAM = 0
        SAY = 0
        SATIR = SATIR + 2
    Next
    
    S1.Columns("IV:IV").Delete
    S2.Cells.EntireColumn.AutoFit
    S2.Select
    
    Set BUL = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[konas06]

Verileriniz Firma bazında sıralayıp Veri / Alt Toplam Yardımı ile ekteki gibi yapabilirsiniz.

Çok teşekkür ederim.
Selamlar.

 

[konas06]

iyi çalışmalar...

Çok teşekkürler.
Selamlar.

 

[konas06]

Selamlar,

Sorunuzu makrolar bölümüne sorduğunuz için bende makrolu çözüm hazılramıştım.

3. Alternatif olarak ekteki örnek dosyayı incelermisiniz.

Uygulanan kod;

Option Explicit
 
Sub GRUPLAYARAK_AKTAR()
    Dim S1 As Worksheet, S2 As Worksheet, SAY As Integer, TOPLAM As Double
    Dim X As Long, SATIR As Long, BUL As Range, ADRES As String
    
    Set S1 = Sheets("ilk hali")
    Set S2 = Sheets("Sayfa2")
    
    S1.Range("D5:D65536").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=S1.Range("IV1"), Unique:=True
    S1.Columns("IV:IV").Sort Key1:=S1.Range("IV1"), Order1:=xlAscending, Header:=xlGuess, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
    
    S2.Range("A:B").Clear
    S2.Range("A1") = "FİRMA ADI"
    S2.Range("A1").Font.Bold = True
    S2.Range("B1") = "TUTAR"
    S2.Range("B1").Font.Bold = True
    SATIR = 2
    
    For X = 2 To S1.Range("IV65536").End(3).Row
        Set BUL = S1.Range("D:D").Find(S1.Cells(X, "IV"), , , xlWhole)
        If Not BUL Is Nothing Then
            ADRES = BUL.Address
            Do
            S2.Cells(SATIR, "A") = S1.Cells(X, "IV")
            S2.Cells(SATIR, "B") = BUL.Offset(0, 1)
            TOPLAM = TOPLAM + BUL.Offset(0, 1)
            SATIR = SATIR + 1
            SAY = SAY + 1
            Set BUL = S1.Range("D:D").FindNext(BUL)
            Loop While Not BUL Is Nothing And BUL.Address <> ADRES
        End If
        
        S2.Cells(SATIR, "A") = SAY & " Adet"
        S2.Cells(SATIR, "A").Font.Bold = True
        S2.Cells(SATIR, "A").Interior.ColorIndex = 6
        
        S2.Cells(SATIR, "B") = TOPLAM
        S2.Cells(SATIR, "B").Font.Bold = True
        S2.Cells(SATIR, "B").Interior.ColorIndex = 6
        
        TOPLAM = 0
        SAY = 0
        SATIR = SATIR + 2
    Next
    
    S1.Columns("IV:IV").Delete
    S2.Cells.EntireColumn.AutoFit
    S2.Select
    
    Set BUL = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Hocam çok teşekkür ederim.
Emeğinize sağlık.