Benzersiz Verileri Tablo Olarak Yeni Bir Excelde Kaydetme

[Astalavista58]

Merhabalar, herkese hayırlı geceler. Ekteki örnek dosyada Sayfa1'deki D ve F sütunundaki verileri benzersiz olarak, yeni bir excelde tablo oluşturup, oluşturulan bu tabloda D ve F sütunundaki verilere bağlı olarak verileri saydırmak istiyorum. En sonunda da exceli masaüstüne kaydetsin.
Yapmak istediğim ekteki dosyanın Sayfa2'sinde mevcut. Bunu çokeğersay ile yapıyorum ancak VBA ile yapılabilirse işlerimi çok kolaylaştırıp kullanmış olduğum excelide bir o kadar rahatlatacak

 

[muygun]

Merhaba;
Eki deneyin.
İyi çalışmalar.

 

[Astalavista58]

Merhaba;
Eki deneyin.
İyi çalışmalar.

Sayın hocam çok teşekkür ediyorum Allah sizden razı olsun

 

[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 COUNT([RÜTBESİ]) " & _
             " SELECT [BİRİMİ] FROM [Sayfa1$A:G] " & _
             " GROUP BY [BİRİMİ] PIVOT [RÜTBESİ] "

    With Sheets("Sayfa2")
        .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 = rgbSilver
            End With
        Next
       
        With .Cells(Rows.Count, 1).End(3).Offset(1)
            .Cells(1).Value = "TOPLAM"
            With .Offset(, 1).Resize(, rs.Fields.Count - 1)
                .FormulaR1C1 = "=SUM(R2C:R[-1]C)"
                .Value = .Value
            End With
            With .Resize(, rs.Fields.Count)
                .Font.Bold = True
                .Interior.Color = rgbSilver
            End With
        End With
       
        .Columns.AutoFit
        .Copy
        Application.DisplayAlerts = False
        ActiveWorkbook.SaveAs Environ("USERPROFILE") & "\DESKTOP\RAPOR.XLSX"
        ActiveWorkbook.Close
        Application.DisplayAlerts = True
       
    End With
    Set rs = Nothing

End Sub

 

[Astalavista58]

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 COUNT([RÜTBESİ]) " & _
             " SELECT [BİRİMİ] FROM [Sayfa1$A:G] " & _
             " GROUP BY [BİRİMİ] PIVOT [RÜTBESİ] "

    With Sheets("Sayfa2")
        .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 = rgbSilver
            End With
        Next
     
        With .Cells(Rows.Count, 1).End(3).Offset(1)
            .Cells(1).Value = "TOPLAM"
            With .Offset(, 1).Resize(, rs.Fields.Count - 1)
                .FormulaR1C1 = "=SUM(R2C:R[-1]C)"
                .Value = .Value
            End With
            With .Resize(, rs.Fields.Count)
                .Font.Bold = True
                .Interior.Color = rgbSilver
            End With
        End With
     
        .Columns.AutoFit
        .Copy
        Application.DisplayAlerts = False
        ActiveWorkbook.SaveAs Environ("USERPROFILE") & "\DESKTOP\RAPOR.XLSX"
        ActiveWorkbook.Close
        Application.DisplayAlerts = True
     
    End With
    Set rs = Nothing

End Sub

Sayın hocam şuan dışarıdayim.eve geçince deneyeceğim, şimdiden elinize sağlık Allah razı olsun.
Binlerce satırlık veriyi bir kaç saniye içinde istediğim şekilde yapıyor. Tekrardan çok teşekkür ederim. Hayırlı kandiliniz olsun, bu mubarek günde dualarınız kabul olsun inşallah