aşağıdaki çalışmayı inceler misiniz?
1 - tüm dosyalar aynı klasörde olmalı
2 - referanslardan Microsoft ActiveX Data Object x.x library eklenmeli
3 - 4. hakedis dosyanızda fazladan bir DTR TARİHİ sütunu vardı o sütun silindi
4 - dosyanız macro çalıştıran formata çevrildi xlsm
Verileri alma fonksiyonu
Option Compare Text' sayfanın en başına küçük/büyük harf farkı olmasın diye
Sub VeriAl()
Dim Sql As String
Dim ADO_CN As ADODB.Connection
xSQL = dosyaAdi_FSO
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 Uni.Plk, Count(Uni.Plk) AS SayF1, Sum(Uni.Tplm) AS ToplaF6 " & _
"FROM (" & xSQL & ") as Uni " & _
"GROUP BY Uni.Plk;"
Set ADO_RS = ADO_CN.Execute(SQL) ' güncelleme yapabilmek için 1,3 0lmalı yada adOpenKeyset, adLockOptimistic
' Eğer Hiç Kayıt Yoksa
If ADO_RS.RecordCount = 0 Then
MsgBox "Kayıt Bulunamadı.", vbCritical, "Veri Yok"
GoTo son
End If
Sheets("sayfa1").Range("B2").CopyFromRecordset ADO_RS
son:
ADO_RS.Close
ADO_CN.Close
Set ADO_RS = Nothing
Set ADO_CN = Nothing
End SubFunction dosyaAdi_FSO() As String
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)
SqlDsy = SqlDsy & SyfAdiAl(f.Path)
End If
Next f
End If
End With
dosyaAdi_FSO = Mid(SqlDsy, 10)
End FunctionFunction 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 = "Union all " & _
"SELECT [" & tbl.Fields(1).Name & "] as Plk,[" & tbl.Fields(5).Name & "] as Tplm " & _
"FROM [" & SyfAdiAl & "B:F] IN """ & fn & """ ""EXCEL 12.0 xml;"" "
Set db = Nothing
Set conn = Nothing
End Function
