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
