Birden fazla kapalı dosya da arama yapmak

[thefrost]

Hocam İyi Akşamlar,

Forumda aradım konuları ama benim aradığımı bulamadım. Elimde bir klasör içerisinde çok sayıda excel dosyası bulunmakta. Benim isteğim bu klasör içindeki excel dosyalarından benim kullandığım excel dosyasındaki 1. sütundaki değerleri araması ve hangi dosyada bulursa o dosyanın ismini yanındaki sütuna yazması.
Şimdiden yardımınız için çok teşekkür ederim..

 

[Murat OSMA]

Dosyalarınızı ekleyiniz.

 

[thefrost]

Hocam ekledim dosyaları.

Bulgular dosyası benim işlem yapacağım dosyam. Diğerleri de arama yapmak istediklerim. Tabi bu arama yapmak istediklerimden klasör içerisinde 26 dosya var. Yardımınız için çok teşekkürler...

 

[Murat OSMA]

Şu an dışarıdayım ilgilenemeyecegim ama bu akşam çözemezseniz yarın gerekli kodları yollarım.

 

[thefrost]

Bu akşam geç de olsa cevaplarsanız çok sevinirim.. iyi akşamlar...

 

[Murat OSMA]

Bulunduğum ortamda bilgisayar yok maalesef, arkadaşların ilgilenmesini rica edeceğim.

 

[baydeniro]

Şimdi ben de merak ettim sayın Murat Osma. Bu görev tam sizlik bir işe benziyor.

 

[Murat OSMA]

Eğer hâlâ ihtiyacınız varsa şu kodları kullanabilirsiniz;

Not: Acemilik1 olan dosya adını Acemilik olarak değiştirin.

Sub Kapalı_Dosyalarda_Arama()
    Dim con As Object, rs As Object, fso As Object, dosya As Object
    Dim sorgu As String, yol As String, sayfa As String, i As Integer
    yol = ThisWorkbook.Path
    Set fso = CreateObject("Scripting.Filesystemobject")
    Set con = CreateObject("adodb.connection")
    Set rs = CreateObject("adodb.recordset")
    For Each dosya In fso.getfolder(yol).Files
        If dosya.Name <> ThisWorkbook.Name Then
            con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
            dosya & ";extended properties=""Excel 12.0;hdr=no"""
            sayfa = Replace(dosya.Name, ".xls", "")
            For i = 2 To Range("A65536").End(3).Row
                sorgu = "select f1 from [" & sayfa & "$]"
                sorgu = sorgu & "where f1='" & Cells(i, "A") & "'"
                rs.Open sorgu, con, 1, 1
                If rs.RecordCount > 0 Then
                    Cells(i, 2) = sayfa
                End If
            rs.Close
            Next i
            con.Close
        End If
    Next dosya
    i = Empty: sayfa = "": yol = "": sorgu = "": Set dosya = Nothing
    Set fso = Nothing: Set rs = Nothing: Set con = Nothing
End Sub

 

[blackinci]

Murat bey böyle bir şeye ihtiyacım var sizin verdiğiniz kodları kullanmak istediğimde
dış tablo istenen biçimde değil diye bir hata alıyorum