kapalı kaynak dosyalarının tamamının alt toplamlarını almak

[caytug]

Arkadaşlar,
kapalı halde 17 kaynak dosyam var, hepsi standart 6 sütün var, veriler 2. satırdan başlıyor fakat satır sayıları farklı,
her dosyada C,D,E,F sütunlarının ayrı ayrı alt toplamlarını alarak
17 dosyadaki C,D,E,F alt toplamlarının genel toplamını makronun çalıştırıldığı dosyaya tek satıra kaydetsin istiyorum.
yardımlarınız için teşekkür ederim.
örnek dosya ekliyorum.

 

[caytug]

Her dosyanın C,D,E,F sütunlarının alt toplamları, makronun çalıştırıldığı dosyaya alt alta yazılması yeterli arkadaşlar,genel toplamı manuelde alırım.

 

[caytug]

Sitede araştırdım ama bu tarzda bulamadım.

 

[Korhan Ayhan]

Deneyiniz.

 

[caytug]

Sayın Korhan,
Ellerinize sağlık, bu çözümler kamuda işlerimizi çok kolaylaştırıyor, Allah razı olsun.

 

[caytug]

Sayın Korhan, şöyle bir ihtiyaç hasıl oldu
B sütunu isimlerden oluşuyor ve aynı şekilde diğerlerinin yanında b sütunununda toplam sayısı ihtiyaç oldu mümkünse.Teşekkür ederim.

Option Explicit

Sub Sutun_Toplamlarini_Aktar()
Dim Dosya As Variant, S1 As Worksheet, X As Integer, Zaman As Double
Dim Baglanti As Object, Sorgu As String, Kayit_Seti As Object

Dosya = Application.GetOpenFilename(FileFilter:="Excel Çalışma Kitapları (*.xl*),*.xl*", _
Title:="Lütfen Dosya Seçiniz...", MultiSelect:=True)

Zaman = Timer

If IsArray(Dosya) <> False Then
Set Baglanti = CreateObject("AdoDb.Connection")
Set S1 = Sheets("Sayfa1")

S1.Range("A2:E" & S1.Rows.Count).Clear

For X = LBound(Dosya) To UBound(Dosya)
If Dosya(X) <> ThisWorkbook.FullName Then
Baglanti.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
Dosya(X) & ";Extended Properties=""Excel 12.0;Hdr=No"""

Sorgu = "Select Sum(F3),Sum(F4),Sum(F5),Sum(F6) From [Sheet0$A:F]"
Set Kayit_Seti = Baglanti.Execute(Sorgu)

With S1.Cells(S1.Rows.Count, 1).End(3)(2, 1)
.CopyFromRecordset Kayit_Seti
.Offset(, 4) = Dosya(X)
End With

If Kayit_Seti.State <> 0 Then Kayit_Seti.Close
If Baglanti.State <> 0 Then Baglanti.Close
End If
Next

With S1
.Columns.AutoFit
.Range("A1:E" & S1.Cells(S1.Rows.Count, 1).End(3).Row).Borders.LineStyle = 1
End With

Set Kayit_Seti = Nothing
Set Baglanti = Nothing
Set S1 = Nothing

MsgBox "Veri aktarımı tamamlanmıştır." & Chr(10) & Chr(10) & _
"İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
Else
MsgBox "Dosya seçimi yapmadığınız için işlemini iptal edilmiştir.", vbCritical
End If
End Sub

 

[Korhan Ayhan]

Örnek dosyalar üzerinden tarif ediniz.

 

[caytug]

Sayın Korhan, ekli dosyada açıkladım.

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Sutun_Toplamlarini_Aktar()
    Dim Dosya As Variant, S1 As Worksheet, X As Integer, Zaman As Double
    Dim Baglanti As Object, Sorgu As String, Kayit_Seti As Object
    
    Dosya = Application.GetOpenFilename(FileFilter:="Excel Çalışma Kitapları (*.xl*),*.xl*", _
            Title:="Lütfen Dosya Seçiniz...", MultiSelect:=True)

    Zaman = Timer
    
    If IsArray(Dosya) <> False Then
        Set Baglanti = CreateObject("AdoDb.Connection")
        Set S1 = Sheets("Sayfa1")
        
        S1.Range("A2:F" & S1.Rows.Count).Clear
        
        For X = LBound(Dosya) To UBound(Dosya)
            If Dosya(X) <> ThisWorkbook.FullName Then
                Baglanti.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
                Dosya(X) & ";Extended Properties=""Excel 12.0;Hdr=No"""
                            
                Sorgu = "Select Count(F2),Sum(F3),Sum(F4),Sum(F5),Sum(F6) From [Sheet0$A2:F]"
                Set Kayit_Seti = Baglanti.Execute(Sorgu)
                
                With S1.Cells(S1.Rows.Count, 1).End(3)(2, 1)
                    .CopyFromRecordset Kayit_Seti
                    .Offset(, 5) = Dosya(X)
                End With
                
                If Kayit_Seti.State <> 0 Then Kayit_Seti.Close
                If Baglanti.State <> 0 Then Baglanti.Close
            End If
        Next
    
        With S1
            .Columns.AutoFit
            .Range("A1:F" & S1.Cells(S1.Rows.Count, 1).End(3).Row).Borders.LineStyle = 1
        End With
            
        Set Kayit_Seti = Nothing
        Set Baglanti = Nothing
        Set S1 = Nothing
            
        MsgBox "Veri aktarımı tamamlanmıştır." & Chr(10) & Chr(10) & _
               "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
    Else
        MsgBox "Dosya seçimi yapmadığınız için işlemini iptal edilmiştir.", vbCritical
    End If
End Sub

 

[caytug]

Sayın Korhan,
kişi sayılarını 1 fazla alıyor, sanırım ilk satırdaki başlığıda sayıyor.

 

[Korhan Ayhan]

Kodu revize ettim. Son halini deneyiniz.

 

[caytug]

Sayın Korhan, ellerinize sağlık düzgün çalışıyor,çok teşekkürler.