- Katılım
- 11 Şubat 2021
- Mesajlar
- 106
- Excel Vers. ve Dili
- 2019, rus
Merhaba dosyadaki bu kod düne kadar çalışıyorken, bu gün hata verdi, sorun ne acaba?
Kod:
Sub XLBirlestir()
'hy__________________________________________Excel Excel Bağla Referanslı
'önce referanslardan mirosoft ActiveX Data Object x.x library eklenmeli
Set Syf = ThisWorkbook.Worksheets("TOTAL")
sonStr = Syf.Cells(Syf.Rows.Count, "B").End(xlUp).Row
If sonStr < 4 Then sonStr = 4
Syf.Range("B4:F" & sonStr).ClearContents
Sheets("TmpTotal").Cells.Clear
Dim SQL As String
Dim ADO_RS As ADODB.Recordset
Dim ADO_CN As ADODB.Connection
AnaKlsr = ThisWorkbook.Path & "\Data\"
DtDsy = Dir(AnaKlsr & "*.xlsx")
Do While DtDsy <> ""
SqlDsy = SqlDsy & _
"Union all " & _
"SELECT * " & _
"FROM [Hesabat$] IN """ & AnaKlsr & DtDsy & """ ""EXCEL 8.0;"" "
DtDsy = Dir
Loop
SqlDsy = Mid(SqlDsy, 11)
SQL = "SELECT * " & _
"FROM (" & SqlDsy & ") AS A " & _
"WHERE (((A.F1) Is Not Null)) OR (((A.F1)>0)) ;"
Set ADO_RS = New ADODB.Recordset
Set ADO_CN = New ADODB.Connection
ADO_CN.ConnectionString = "provider=Microsoft.ACE.OLEDB.12.0;data source=" & ThisWorkbook.FullName & _
";extended properties=""excel 8.0;hdr=No"""
ADO_CN.Open
ADO_RS.Open SQL, ADO_CN, 3, 1
' Eğer Hiç Kayıt Yoksa
If ADO_RS.RecordCount = 0 Then
MsgBox "Kayıt Bulunamadı.", vbCritical, "Veri Yok"
GoTo son
End If
ADO_RS.MoveLast
ADO_RS.MoveFirst
Sheets("TmpTotal").Range("A1").CopyFromRecordset ADO_RS
ADO_RS.Close
'hy_____________________________________ToplaRS
SQL = "SELECT [F2], Sum([F3]) AS TplA3, Sum([F4]) AS TplA4, Sum([F5]) AS TplA5, Sum([F6]) AS TplA6 " & _
"FROM [TmpTotal$] " & _
"GROUP BY [F2];"
Set ADO_RS = New ADODB.Recordset
ADO_RS.Open SQL, ADO_CN, 3, 1
' Eğer Hiç Kayıt Yoksa
If ADO_RS.RecordCount = 0 Then
MsgBox "Kayıt Bulunamadı.", vbCritical, "Veri Yok"
GoTo son
End If
ADO_RS.MoveLast
ADO_RS.MoveFirst
Sheets("Total").Range("B4").CopyFromRecordset ADO_RS
son:
ADO_RS.Close
ADO_CN.Close
'hy_____________________________________ToplaRS
Sheets("TmpTotal").Cells.Clear
Set ADO_RS = Nothing
Set ADO_CN = Nothing
End Sub