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_FSO2 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_son hali", t2 - t1
'MsgBox "Bitti"
End Sub
Sub dosyaAdi_FSO2(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
Dim conn2 As Object
Set conn2 = CreateObject("DAO.DBEngine.120")
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 SyfAdiAl2(f.Path, conn2)
End If
Next f
Set conn2 = Nothing
End If
End With
End Sub
Function SyfAdiAl2(fn As String, conn As Object) As String 'fn tam yol + ad
Dim db As Object
Dim tbl As Object
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)
SyfAdiAl2 = CStr(Replace(tbl.Name, "'", "")) ' sadece ilk sayfa tblAdi = CStr(Replace(tbl.Name, "'", ""))
SyfAdiAl2 = "INSERT INTO [Tmpsayfa$] ([Plaka], [TOPLAM TUTAR]) " & _
"SELECT [Plaka] ,[TOPLAM TUTAR] " & _
"FROM [" & SyfAdiAl2 & "] IN """ & fn & """ ""EXCEL 12.0 xml;"" "
Set db = Nothing
End Function
aşağıdaki kod daha hızlı gibi
