Sub Dosyalar_Ado()
'Dosyalar arası bilinmeyen sayfalarda koşullu veri çekme
'Feyzullah KILINÇ metehan8001**** 14.07.2019
Set con = CreateObject("Adodb.Connection")
Set rs = CreateObject("Adodb.Recordset")
Set cat = CreateObject("adox.catalog")
Set tbl = CreateObject("adox.table")
Set Fso = CreateObject("Scripting.FileSystemObject")
Set Klasor = Fso.GetFolder(ThisWorkbook.Path)
For Each dosyalar In Klasor.Files
If dosyalar.Name <> ThisWorkbook.Name Then
If Right(dosyalar.Name, Len(dosyalar.Name) - 2) <> ThisWorkbook.Name Then
con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
dosyalar & ";extended properties=""Excel 12.0;imex=1;hdr=no"""
cat.activeconnection = con
For a = 2 To Cells(Rows.Count, "J").End(xlUp).Row
For Each c In Range("P1:R1")
For Each syf In cat.tables
syfadi = Replace(Replace(Replace(syf.Name, "'", ""), "$", ""), "#", "")
If syfadi = Replace(c.Value, ".", "") Then
sayfa = Replace(syf.Name, "'", "")
Exit For
End If
Next
sorgu = "select f6 from [" & sayfa & "] Where f1 = '" & Cells(a, "j") & "'"
rs.Open sorgu, con, 1, 1
If rs.RecordCount > 0 Then Cells(a, c.Column).CopyFromRecordset rs
rs.Close
sorgu = "select f12 from [" & sayfa & "] Where f7 = '" & Cells(a, "j") & "'"
rs.Open sorgu, con, 1, 1
If rs.RecordCount > 0 Then Cells(a, c.Column).CopyFromRecordset rs
rs.Close
Next c
Next a
con.Close
End If
End If
Next
Set rs = Nothing: Set con = Nothing
MsgBox "İşlem tamam", vbInformation + vbMsgBoxRtlReading, "İşlem Tamamlandı."
End Sub