Not: 'Önce referanslardan Microsoft ActiveX Data Objects x.x library eklenmeli
'x.x yerine bilgisayardaki sürüm olmalı
'Microsoft ActiveX Data Objects 2.0 Library
'Microsoft ActiveX Data Objects 2.8 Library
'Microsoft ActiveX Data Objects 6.0 Library gibi
Sub ImportDataFromMultipleWorkbooks()
Dim vaFiles As Variant
Dim ws As Worksheet
ThisWorkbook.Activate
Set ws = Sayfa1
un = "Sayın " & Environ("UserName")
ms1 = MsgBox("Birden fazla dosyadan veri almak istiyor musunuz?", vbInformation + vbYesNo, un)
If ms1 = vbYes Then
ws.Range("A3:K" & Rows.Count).Clear
vaFiles = Application.GetOpenFilename( _
FileFilter:="Microsoft Excel Workbooks(*.xls;*.xlsx;*.xlsb;*.xlsm),*.xls;*.xls;*.xlsx;*.xlsb;*.xlsm", _
Title:="Select Files to Proceed", MultiSelect:=True)
With Application
.DisplayAlerts = False
.ScreenUpdating = False
End With
If IsArray(vaFiles) Then
For i = LBound(vaFiles) To UBound(vaFiles)
If vaFiles(i) = ThisWorkbook.FullName Then
ms4 = MsgBox("Cannot Open Itself", vbExclamation, un)
GoTo skipfile:
End If
'hy Recordset___________________________
Dim Sql As String
Dim ADO_RS As ADODB.Recordset
Dim ADO_CN As ADODB.Connection
sonStr = ws.Range("A" & Rows.Count).End(3).Row + 1
SQL = "SELECT * " & _
"FROM [Sayfa1$A3:I] " & _
"where [F2] Is Not Null"
Set ADO_RS = New ADODB.Recordset
Set ADO_CN = New ADODB.Connection
ADO_CN.ConnectionString = "provider=Microsoft.ACE.OLEDB.12.0;data source=" & vaFiles(i) & _
";extended properties=""excel 12.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 skipfile:
End If
ADO_RS.MoveLast
ADO_RS.MoveFirst
ws.Range("A" & sonStr).CopyFromRecordset ADO_RS 'excelde
skipfile:
ADO_RS.Close
ADO_CN.Close
Set ADO_RS = Nothing
Set ADO_CN = Nothing
'_______________________________________
Next i
ws.Range("A2:K2").EntireColumn.AutoFit
ms5 = MsgBox("Verileriniz ana dosyaya aktarılmıştır", vbInformation, un)
Else
ms3 = MsgBox("Dosya seçmediniz!", vbExclamation, un)
End If
Else
ms2 = MsgBox("Başarısız!", vbInformation, un)
End If
With Application
.DisplayAlerts = True
.ScreenUpdating = True
End With
End Sub
