kodlar yeniden düzenlenmiştir
modüldeki tüm kodları silip aşağıdaki kodları yapıştırarak dener misiniz?
bu arada @lemoncher2 hocamın da belirttiği gibi lütfen her önerimiz için bildirimde bulunun ki başka üyeler de faydalansınlar

1 - tüm dosyalar aynı klasörde olmalı
2 - referanslardan Microsoft ActiveX Data Object x.x library eklenmeli
3 - dosyanız macro çalıştıran formata çevrildi xlsm
4 - TmpSayfa adında bir sayfa eklendi veriler önce bu sayfaya ekleniyor toplamları alındıktan sonra sayfadaki veriler siliniyor

Option Compare Text



Sub VeriAl()

't1 = Timer

Application.ScreenUpdating = False

Dim Sql As String

Dim ADO_CN As ADODB.Connection



Set ADO_CN = New ADODB.Connection



ADO_CN.ConnectionString = "provider=Microsoft.ACE.OLEDB.12.0;data source=" & ThisWorkbook.FullName & _

                          ";extended properties=""excel 12.0 Xml;hdr=Yes"""

ADO_CN.Open



SQL = "SELECT [PLAKA], Count([PLAKA]), Sum([TOPLAM TUTAR]) " & _

      "FROM [TmpSayfa$] " & _

      "GROUP BY [PLAKA];"

      

Set SyfTmp = ThisWorkbook.Worksheets("TmpSayfa")

With SyfTmp

    .Cells.Clear

    .Cells(1, 1) = "PLAKA"

    .Cells(1, 2) = "TOPLAM TUTAR"

End With

dosyaAdi_FSO ADO_CN

Set ADO_RS = ADO_CN.Execute(SQL)



'  Eğer Hiç Kayıt Yoksa

If ADO_RS.RecordCount = 0 Then

    MsgBox "Kayıt Bulunamadı.", vbCritical, "Veri Yok"

    GoTo son

End If

Set Syf = Sheets("Sayfa1")

Syf.Range("B2").CopyFromRecordset ADO_RS

SonStr = Syf.Cells(Syf.Rows.Count, "B").End(xlUp).Row - 1

    With Syf.Range("a2")

        .Value = 1

        .AutoFill .Resize(SonStr, 1), xlFillSeries

    End With

son:

SyfTmp.Cells.Clear

ADO_RS.Close

ADO_CN.Close

Set ADO_RS = Nothing

Set ADO_CN = Nothing

Application.ScreenUpdating = True

't2 = Timer

'Debug.Print "hy4_screen var", t2 - t1

MsgBox "Bitti"

End Sub

Sub dosyaAdi_FSO(con As ADODB.Connection)

Dim FSO As Object '//FileSystemObject

Dim f As Object '//File Object

AnaKlsr = ThisWorkbook.Path & "\"

 

 Set FSO = CreateObject("Scripting.FileSystemObject")

With FSO

    If .FolderExists(AnaKlsr) Then

        For Each f In .GetFolder(AnaKlsr).Files

            If f.Name <> ThisWorkbook.Name And Left(f.Name, 1) <> "~" And f.Type Like "*excel*" Then 'Debug.Print say, f.Name, SyfAdiAl(f.Path)

                con.Execute SyfAdiAl(f.Path)

            End If

        Next f

    End If

End With

End Sub

Function SyfAdiAl(fn As String) As String 'fn tam yol + ad

    Dim conn As Object, db As Object

    Dim tbl As Object



    Set conn = CreateObject("DAO.DBEngine.120")

    Set db = conn.OpenDatabase(fn, False, True, "Excel 12.0 Xml;HDR=Yes;")

    

    Set tbl = db.TableDefs(0) ' 0 is Sheets(1) : 1 is Sheets(2)

    SyfAdiAl = CStr(Replace(tbl.Name, "'", ""))  ' sadece ilk sayfa tblAdi = CStr(Replace(tbl.Name, "'", ""))

    SyfAdiAl = "INSERT INTO [Tmpsayfa$] ([Plaka], [TOPLAM TUTAR]) " & _

              "SELECT [Plaka] ,[TOPLAM TUTAR] " & _

              "FROM [" & SyfAdiAl & "] IN """ & fn & """ ""EXCEL 12.0 xml;"" "

    Set db = Nothing

    Set conn = Nothing



End Function