Soru Makro ile Tablo Özetleme

[bulentkars]

Değerli Arkadaşlar Merhaba,

Ekteki Tabloda örnek olarak yazdım,

Çoketopla ile yaptığım işlemi makro ile yapmak istiyorum. Tabloda Şube isimleri dinamik buna göre yardımcı olabilirseniz çok sevinirim.Şimdiden çok teşekkür ederim.

 

[Haluk]

Pivot Tablo bu iş için mükemmel olur....





.

 

[bulentkars]

Haluk Bey

Dosyası fazla kullanıcılar pivotu kullanamıyor. Sürekli sorun çıkarabiliyor. Tablo bitikten sonra başı hesaplamalar da yapıldığı için makro ile istedim. Yardımcı olabilirseniz sevinirim.

 

[ÖmerFaruk]

Bilgisayarda Net Framework 3.5 olması gerekir.
Net Framework 3.5 Buradan indirebilrisiniz.

Boş bir module aşağıdaki kodları ekleyip çalıştırabilirsiniz.

Sub YeniÖzetTablo()
    Dim Subeler As Object, Tarihler As Object
    Dim Liste, Veri, i As Integer, x As Integer, y As Integer
    Veri = Worksheets("Data").Range("A1").CurrentRegion.Value
    Set Subeler = CreateObject("System.Collections.ArrayList")
    Set Tarihler = CreateObject("System.Collections.ArrayList")
    For i = 2 To UBound(Veri)
        If Not Subeler.Contains(Veri(i, 1)) Then Subeler.Add Veri(i, 1)
        If Not Tarihler.Contains(Veri(i, 3)) Then Tarihler.Add Veri(i, 3)
    Next i
    Subeler.Sort
    Tarihler.Sort
    ReDim Liste(1 To Tarihler.Count + 3, 1 To Subeler.Count + 2)
    Liste(1, 1) = "GÜNLER"
    Liste(1, UBound(Liste, 2)) = "Toplam Koli"
    Liste(UBound(Liste), 1) = "Toplam"
    For i = 1 To Subeler.Count
        Liste(1, i + 1) = Subeler(i - 1)
    Next i
    For i = 1 To Tarihler.Count
        Liste(i + 1, 1) = Tarihler(i - 1)
    Next i
    For i = 2 To UBound(Veri)
        x = Tarihler.indexof(Veri(i, 3), 0) + 2
        y = Subeler.indexof(Veri(i, 1), 0) + 2
        Liste(x, y) = Liste(x, y) + Veri(i, UBound(Veri, 2))
        Liste(UBound(Liste), y) = Liste(UBound(Liste), y) + Veri(i, UBound(Veri, 2))
        Liste(x, UBound(Liste, 2)) = Liste(x, UBound(Liste, 2)) + Veri(i, UBound(Veri, 2))
    Next i
    Worksheets("Özet Tablo").Cells.Clear
    Worksheets("Özet Tablo").Range("A1").Resize(UBound(Liste, 1), UBound(Liste, 2)) = Liste
    Set Alan = Worksheets("Özet Tablo").Range("A1").Resize(UBound(Liste, 1), UBound(Liste, 2))
    With Alan
    .VerticalAlignment = xlVAlignCenter
    .HorizontalAlignment = xlHAlignCenter
    .Rows(1).Interior.Color = vbYellow
    .Rows(.Rows.Count).Interior.Color = vbYellow
    .Rows(.Rows.Count).Font.Bold = True
    .Borders.LineStyle = xlContinuous
    .Columns.AutoFit
    End With
End Sub

 

[Haluk]

ADO/SQL ile alternatif ekli dosyadadır;

.

 

[veyselemre]

Sub adoOzetle()
    Dim strCon$, strSql$, rs As Object, i%
    strCon = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source='" & ThisWorkbook.FullName & _
             "';Extended Properties=""Excel 12.0;HDR=YES;IMEX=1"";"

    strSql = " TRANSFORM SUM([KOLİ ADET]) " & _
             " SELECT FORMAT([TARİH],'DD.MM.YYYY DDDD') AS GÜNLER," & _
             " SUM([KOLİ ADET]) AS [TOPLAM KOLİ] FROM [Data$A:J] " & _
             " WHERE NOT ([ALICI ŞUBE] IS NULL) " & _
             " GROUP BY [TARİH] PIVOT [ALICI ŞUBE] "

    With Sheets("Özet Tablo")
        .Cells.Clear
        Set rs = CreateObject("Adodb.RecordSet")
        rs.Open strSql, strCon
      
        .[A2].CopyFromRecordset rs
        rs.Close
              
        For i = 0 To rs.Fields.Count - 1
            With .Cells(1, i + 1)
                .Value = rs.Fields(i).Name
                .Font.Bold = True
                .Interior.Color = rgbYellow
            End With
        Next
        
        .Columns(2).Copy .Columns(rs.Fields.Count + 1)
        .Columns(2).Delete
        .[A2].CurrentRegion.Borders.Color = rgbDarkBlue
            
        With .Cells(Rows.Count, 1).End(3).Offset(2)
            .Cells(1).Value = "TOPLAM"
            With .Offset(, 1).Resize(, rs.Fields.Count - 1)
                .FormulaR1C1 = "=SUM(R2C:R[-2]C)"
                .Value = .Value
            End With
            With .Resize(, rs.Fields.Count)
                .Font.Bold = True
                .Interior.Color = rgbYellow
                .Borders.Color = rgbDarkBlue
            End With
        End With
      
        .Columns.AutoFit
      
    End With
    Set rs = Nothing

End Sub

 

[bulentkars]

Değerli Üstadlar,

Ömer Faruk Bey
Haluk Bey,
Veysel Emre Bey
Çalışmalarınız çok güzel allah razı olsun. Elinize emeğinize sağlık. Teşekkür Ediyorum

 

[Korhan Ayhan]

Alternatif...

Özet tablonun makro ile hazırlanmasıyla ilgili örnektir. Süre olarakta bir tık avantaj sağlayacaktır.

 

[bulentkars]

Korhan Bey,

Sizin çalışmanızıda kullanmak istiyorum, sadece ufuk değişiklik yapabilirsek bu çalışmayı farkı bir uygulamda kullanacağım,

mevcut
ALICI ŞUBE "B" sutunuda soldan sağa doğru gidiyor.
Tarih A2 den itibaren aşağı doğru gidiyor.

Talep
A2 den itibaren Alıcı Şube isimleri olacak.
B1 ve sola doğru da tarihleri alabilirsek süper olacak. tarih formatıda "09-10" şeklinde olacak
Ben kodun içinde yapmaya çalıştım beceremedim. sonuç ekteki görünütü gibi olacak.
özet olarak yaptığınızın ters işlemi olacak. şube tarih yerleri değişecek. Teşekkürler

 

[Korhan Ayhan]

Deneyiniz.

 

[bulentkars]

Süpersiniz Korhan Bey,

Allah sizden razı olsun elinize emeğinize sağlık

 

[Haluk]

.......
....

Talep
A2 den itibaren Alıcı Şube isimleri olacak.
B1 ve sola doğru da tarihleri alabilirsek süper olacak. tarih formatıda "09-10" şeklinde olacak
Ben kodun içinde yapmaya çalıştım beceremedim. sonuç ekteki görünütü gibi olacak.
özet olarak yaptığınızın ters işlemi olacak. şube tarih yerleri değişecek. Teşekkürler

Alternatif olarak; 5 No'lu mesaj ekindeki dosyamda SQL'i aşağıdaki gibi değiştirseniz, istediğiniz yeni duruma göre özet tablonuz oluşturulur....

Sub Test2()
    'Haluk 08/10/2022
    'sa4truss@gmail.com
    '
    Dim myDB As String, adoCN As Object, strSql As String, RS As Object
    
    Const adOpenDynamic = 1
    Const adLockOptimistic = 3
    
    myDB = ThisWorkbook.FullName
    
    Sheets("OZET").Cells.Clear
    
    Set adoCon = CreateObject("ADODB.Connection")
    Set RS = CreateObject("ADODB.RecordSet")
    
    adoCon.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
                 myDB & ";Extended Properties=""Excel 12.0;HDR=Yes"""
        
    strSql = " Transform Sum([KOLİ ADET]) " & _
             " Select [ALICI ŞUBE], Sum([KOLİ ADET]) As [Genel Toplam] From [Data$] Where [ALICI ŞUBE] Is Not Null " & _
             " Group by [ALICI ŞUBE] " & _
             " Pivot Format([Tarih],'dd.mm') "
    
    RS.Open Source:=strSql, ActiveConnection:=adoCon, CursorType:=adOpenDynamic, LockType:=adLockOptimistic
    
    Sheets("OZET").Range("A2").CopyFromRecordset RS
        
    With Sheets("OZET")
        .Activate
        
        For j = 0 To RS.Fields.Count - 1
            .Cells(1, j + 1) = RS.Fields(j).Name
            .Cells(1, j + 1).Font.Bold = True
        Next
        
        LastRow = 1 + RS.RecordCount
        
        For j = 2 To RS.Fields.Count
            With .Cells(LastRow + 2, j)
                .FormulaR1C1 = "=SUM(R2C:R[-2]C)"
                .Font.Bold = True
            End With
        Next
        
        .Range("A" & LastRow + 2) = "TOPLAM :"
        .Range("A" & LastRow + 2).Font.Bold = True
        .Range("B:K").ColumnWidth = 10
    End With
    
    RS.Close
    Set RS = Nothing
    Set adoCon = Nothing
End Sub

.

 

[bulentkars]

Teşekkürler Haluk Bey
Allah sizden razı olsun.