• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

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

bulentkars

bulentkars

Altın Üye
Katılım
5 Ağustos 2005
Mesajlar
674
Excel Vers. ve Dili
2003 TR
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
 

Ekli dosyalar

Kod: 
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
 
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.
 
Kod: 
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
 
Son düzenleme:
Merhaba,

Tüm hücreleri sarı yapıyor, benim istediğim sadece üst başlılar ve alttaki toplamların sarıya boyamak istiyorum.
 
Kodları güncelledim. Modüle eklenecek, sayfanın kod kısımlarına değil.
 
Merhaba,

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

Ekli dosyalar

  • Ekran Alıntısı.JPG
    Ekran Alıntısı.JPG
    70.2 KB · Görüntüleme: 4
Kod: 
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
 
Veysel Emre Bey,

Elinize emeğinize sağlık. Zahmet verdim size Allah razı olsun sizden.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst