Soru Data Sayfasındaki Verilerin Özet Toplamını Almak

[bulentkars]

Ardakadaşlar Günaydın,

Ekteki örnek tabloda detaylıcı anlattım,
İsteğim;

Data sayfasında '(Gönderici Ödemeli) olan firmaları Özet sayfasında özetlemek, bu işlemi çokeğer topla mantığı ile makro ile yapmak istiyorum. Yardımcı olabilirseniz sevinirim. Şimdiden Teşekkürler

 

[veyselemre]

Sub test()

    With Sheets("Data")
        son = .Cells(Rows.Count, 1).End(3).Row
        veri = .Range("A2:J" & son)
        ReDim liste(1 To UBound(veri) + 1, 1 To 1)
    End With
            
    firmaSay = 1
    subeSay = 1
    
    With CreateObject("Scripting.Dictionary")
        
        For i = 1 To UBound(veri)
            If veri(i, 7) = "(Gönderici Ödemeli)" Then
                firma = veri(i, 6)
                sube = veri(i, 1)
                adet = Val(veri(i, 10))
                If Not .exists(firma) Then
                    firmaSay = firmaSay + 1
                    .Item(firma) = firmaSay
                    liste(firmaSay, 1) = firma
                End If
                If Not .exists(sube) Then
                    subeSay = subeSay + 1
                    .Item(sube) = subeSay
                    ReDim Preserve liste(1 To UBound(veri) + 1, 1 To subeSay)
                    liste(1, subeSay) = sube
                End If
                liste(.Item(firma), .Item(sube)) = liste(.Item(firma), .Item(sube)) + adet
            End If
        Next i
    
    End With
    
    With Sheets("Özet")
        
        .Range("a1:G" & Rows.Count).Clear
        .Range("a1").Resize(firmaSay, subeSay).Value = liste
        .Cells(firmaSay + 1, 1).Value = "Toplam"
        .Cells(1, subeSay + 1).Value = "Toplam Koli Adedi"
        .Cells(1, subeSay + 2).Value = "Tutar"
        
        With .Cells(firmaSay + 1, 2).Resize(, subeSay - 1)
            .FormulaR1C1 = "=SUM(R2C:R[-1]C)"
            .Value = .Value
        End With
        
        With .Cells(2, subeSay + 1).Resize(firmaSay)
            .FormulaR1C1 = "=SUM(RC2:RC[-1])"
            .Value = .Value
        End With
        
        With .Cells(2, subeSay + 2).Resize(firmaSay)
            .FormulaR1C1 = "=RC[-1] * R1C17"
            .Value = .Value
        End With
        
        With .Range("A1").Resize(firmaSay + 1, subeSay + 2)
            .Columns.AutoFit
            .Borders.Color = rgbSilver
        End With
        
    End With
  
End Sub

 

[bulentkars]

Veysel Emre Bey;

Çok Çok teşekkür ederim. Tam istediğim gibi olmuş, Allah sizden razı olsun,

Sadece aşağıdaki taleplerimi zahmet olmayacaksa çok sevinirim. Teşekkürler

.Borders.Color = rgbSilver " Çizgi rengini Koyu mavi yapmak istiyorum yapamadım.
Toplam Satırları ve başlık satırları Koyu ve artalan renk sarı olursa
Tutar Kısmı da sayı biçimi 0 ve 1000 ayırıcısı kullana bilirsek çok güzel olacak.

 

[veyselemre]

Option Explicit

Sub test()
    Dim son&, veri, liste, firmaSay%, subeSay%, i&
    Dim topSat&, topSut%, firma$, sube$, adet%
    
    With Sheets("Data")
        son = .Cells(Rows.Count, 1).End(3).Row
        veri = .Range("A2:J" & son)
        ReDim liste(1 To UBound(veri) + 1, 1 To 1)
    End With
            
    firmaSay = 1
    subeSay = 1
    
    With CreateObject("Scripting.Dictionary")
        
        For i = 1 To UBound(veri)
            If veri(i, 7) = "(Gönderici Ödemeli)" Then
                firma = veri(i, 6)
                sube = veri(i, 1)
                adet = Val(veri(i, 10))
                If Not .exists(firma) Then
                    firmaSay = firmaSay + 1
                    .Item(firma) = firmaSay
                    liste(firmaSay, 1) = firma
                End If
                If Not .exists(sube) Then
                    subeSay = subeSay + 1
                    .Item(sube) = subeSay
                    ReDim Preserve liste(1 To UBound(veri) + 1, 1 To subeSay)
                    liste(1, subeSay) = sube
                End If
                liste(.Item(firma), .Item(sube)) = liste(.Item(firma), .Item(sube)) + adet
            End If
        Next i
    
    End With
    
    With Sheets("Özet")
        
        .Range("a1:m" & Rows.Count).Clear
        .Range("a1").Resize(firmaSay, subeSay).Value = liste
        .Range("a1").Value = "ALICI ŞUBE"
        topSat = firmaSay + 1
        topSut = subeSay + 1
        
        .Cells(topSat, 1).Value = "TOPLAM"
        .Cells(1, topSut).Value = "Toplam Koli Adedi"
        .Cells(1, topSut + 1).Value = "Tutar"

        With .Cells(2, topSut).Resize(topSat - 1)
            .FormulaR1C1 = "=SUM(RC2:RC[-1])"
            With .Offset(, 1)
                .FormulaR1C1 = "=RC[-1]*R1C17"
            End With
        End With

        With .Cells(topSat, 2).Resize(, topSut)
            .FormulaR1C1 = "=SUM(R2C:R[-1]C)"
        End With
        
        With .Range(.Cells(1, 1), .Cells(topSat, topSut + 1))
            .HorizontalAlignment = xlCenter
            .Borders.Color = rgbDarkBlue
            .Font.Bold = True
            .Interior.Color = rgbYellow
        End With
        
        With .Range(.Cells(2, 2), .Cells(topSat - 1, topSut - 1))
            .Font.Bold = False
            .Interior.Color = xlNone
        End With
        
        With .Range(.Cells(2, topSut + 1), .Cells(topSat, topSut + 1))
            .NumberFormat = "#,##0.00"
            .HorizontalAlignment = xlRight
        End With
        
        With .Range("A1").CurrentRegion
            .Columns.AutoFit
            .Value = .Value
        End With
        
    End With
   
End Sub

 

[bulentkars]

Merhaba,

Tüm hücreleri sarı yapıyor, benim istediğim sadece üst başlılar ve alttaki toplamların sarıya boyamak istiyorum.

 

[veyselemre]

Kodları güncelledim. Modüle eklenecek, sayfanın kod kısımlarına değil.

 

[bulentkars]

Merhaba,

Olmasını istediğim Ekran görüntüsünü paylaştım, Teşekkürler

 

[veyselemre]

Sub test()
    Dim son&, veri, liste, firmaSay%, subeSay%, i&
    Dim topSat&, topSut%, firma$, sube$, adet%
    
    With Sheets("Data")
        son = .Cells(Rows.Count, 1).End(3).Row
        veri = .Range("A2:J" & son)
        ReDim liste(1 To UBound(veri) + 1, 1 To 1)
    End With
            
    firmaSay = 1
    subeSay = 1
    
    With CreateObject("Scripting.Dictionary")
        
        For i = 1 To UBound(veri)
            If veri(i, 7) = "(Gönderici Ödemeli)" Then
                firma = veri(i, 6)
                sube = veri(i, 1)
                adet = Val(veri(i, 10))
                If Not .exists(firma) Then
                    firmaSay = firmaSay + 1
                    .Item(firma) = firmaSay
                    liste(firmaSay, 1) = firma
                End If
                If Not .exists(sube) Then
                    subeSay = subeSay + 1
                    .Item(sube) = subeSay
                    ReDim Preserve liste(1 To UBound(veri) + 1, 1 To subeSay)
                    liste(1, subeSay) = sube
                End If
                liste(.Item(firma), .Item(sube)) = liste(.Item(firma), .Item(sube)) + adet
            End If
        Next i
    
    End With
    
    With Sheets("Özet")
        
        .Range("a1:m" & Rows.Count).Clear
        .Range("a1").Resize(firmaSay, subeSay).Value = liste
        .Range("a1").Value = "ALICI ŞUBE"
        topSat = firmaSay + 1
        topSut = subeSay + 1
        
        .Cells(topSat, 1).Value = "TOPLAM"
        .Cells(1, topSut).Value = "Toplam Koli Adedi"
        .Cells(1, topSut + 1).Value = "Tutar"

        With .Cells(2, topSut).Resize(topSat - 1)
            .FormulaR1C1 = "=SUM(RC2:RC[-1])"
            With .Offset(, 1)
                .FormulaR1C1 = "=RC[-1]*R1C17"
            End With
        End With

        With .Cells(topSat, 2).Resize(, topSut)
            .FormulaR1C1 = "=SUM(R2C:R[-1]C)"
        End With
        
        With .Range(.Cells(1, 1), .Cells(topSat, topSut + 1))
            .HorizontalAlignment = xlCenter
            .Borders.Color = rgbDarkBlue
            .Font.Bold = True
        End With
        
        With .Range(.Cells(2, 2), .Cells(topSat - 1, topSut - 1))
            .Font.Bold = False
            .Interior.Color = xlNone
        End With
        
        With .Range(.Cells(1, 1), .Cells(1, topSut + 1))
            .Interior.Color = rgbYellow
        End With
        
        With .Range(.Cells(topSat, 1), .Cells(topSat, topSut + 1))
            .Interior.Color = rgbYellow
        End With
        
        With .Range(.Cells(2, topSut + 1), .Cells(topSat, topSut + 1))
            .NumberFormat = "#,##0.00"
            .HorizontalAlignment = xlRight
        End With
        
        With .Range("A1").CurrentRegion
            .Columns.AutoFit
            .Value = .Value
        End With
        
    End With

 

[bulentkars]

Veysel Emre Bey,

Elinize emeğinize sağlık. Zahmet verdim size Allah razı olsun sizden.