Bir klasör içerisin de çoklu arama yapmak

[mustilem23]

merhabalar ,

bir klasörüm içerin de 100 lerce excel dosyam var ve bu dosyaların içerin de malzeme nosu diye bir kavram var ben bazen 10 adet malzeme kodu aramam gerekiyor mecburen tek tek arayıp buluyorum .çoklu arama nasıl yapabilirim yardımcı olabilir misiniz.

[mustilem23]

ilgilenebilir iseniz çok makbule geçecek benim için.

[mustilem23]

üstadlar bu konuda yardımcı olabilir iseniz çok makbule geçecek.

[omerceri]

Arama yapılacak dosya yapısını görmek için örnek dosya eklerseniz, daha kolay yardım alırsınız.

[nikferli]

windows arama programı kullan.
indeks oluştursun. sonra aradığın ismi bütün dosyalarda bulur.

[Korhan Ayhan]

Merhaba,

Ekteki örnek dosyayı inceleyiniz.

Dosyayı masaüstüne indirin.
Dosyayı açın butona tıklayın.
İlgili klasörü seçin.
Aramak istediğiniz kodu yazın.
Arkanıza yaslanıp işlemin bitmesini bekleyin.

Kullanılan kod;

Option Explicit

Sub KLASORDE_COKLU_KOD_ARAMA()
    Dim Klasor As Object, Dosya As String, Aranan  As Variant
    Dim Hedef_Kitap As Workbook, Sayfa As Worksheet, Satir As Long
    Dim K1 As Workbook, S1 As Worksheet, Bul As Range, Adres As String
    
    Set K1 = ThisWorkbook
    Set S1 = K1.Sheets("Sayfa1")
    
    Set Klasor = CreateObject("Shell.Application").BrowseForFolder(0, "Klasör seçiniz !", 1)
    If Klasor Is Nothing Then Exit Sub
    
    Aranan = InputBox("Lütfen aradığınız kodu giriniz...", "Kod arama işlemi...")
    If Aranan = False Or Aranan = "" Then Exit Sub
    
    Application.ScreenUpdating = False
    
    S1.Range("A2:D" & Rows.Count).Clear
    Dosya = Dir(Klasor.Self.Path & "\*.*")
    
    While Dosya <> ""
        Set Hedef_Kitap = Workbooks.Open(Klasor.Self.Path & "\" & Dosya, False, False)
        DoEvents
        For Each Sayfa In Hedef_Kitap.Worksheets
            Set Bul = Sayfa.Cells.Find(Aranan, , , xlWhole)
            If Not Bul Is Nothing Then
            Adres = Bul.Address
                Do
                    Satir = S1.Cells(Rows.Count, 1).End(3).Row + 1
                    S1.Cells(Satir, 1) = Dosya
                    S1.Cells(Satir, 2) = Sayfa.Name
                    S1.Cells(Satir, 3) = Bul.Address(False, False)
                    S1.Hyperlinks.Add Anchor:=S1.Cells(Satir, 4), _
                    Address:=Klasor.Self.Path & "\" & Dosya, SubAddress:=Sayfa.Name & "!" & S1.Cells(Satir, 3), _
                    TextToDisplay:="Ulaşmak için tıklayınız..."
                    Set Bul = Sayfa.Cells.FindNext(Bul)
                Loop While Not Bul Is Nothing And Bul.Address <> Adres
            End If
        Next
        Hedef_Kitap.Close 0
        Dosya = Dir
    Wend
    
    S1.Range("A:D").EntireColumn.AutoFit
    
    Set Bul = Nothing
    Set K1 = Nothing
    Set S1 = Nothing
    Set Klasor = Nothing

    Application.ScreenUpdating = True

    If Satir > 1 Then
        MsgBox "İşleminiz tamamlanmıştır.", vbInformation
    Else
        MsgBox Aranan & " numaralı kod bulunamamıştır!", vbCritical
    End If
End Sub

[mustilem23]

Sayın Korhan Bey ,

biliyorum konu hakkında dönüşüm çok geç oldu fakat sanırım email hatıraltıcısı bilgi iletmemiş eski konularımı ararken rastladım ,öncelikle ilginiz için çok tesşekkür ederim ,

rica etsem örnek dosyayı başka bir paylaşım serverine ekleyebilir misiniz.

[feridici_genc]

buyrun,
http://s3.dosya.tc/server30/CHCcMT/_RNEK.rar.html

[mustilem23]

sayın feridici_genc ilginiz için teşekkürler.

Sayın korhan Bey
makro çok güzel çalışıyor fakat sadece gösterilen klasörde arama yapıyor ,o klasöre ait bir alt klasör var ise hata veriyor birde aşağıda resimde bahsetmek istediğim gibi klasör içerisinde excelden farklı bir dosya türü olursa aşağıdaki debug hatasını veriyor.

http://www.resimupload.net.tr/image.php?di=TQ6T

rica etsem butona tıkladığımız da klasöre göz at dediğimiz de bilgisayarımı komple gösterdiğim de referans nosunu yazdığımızda excelleri bulacak şekilde düzenleyeilmeniz mümkün müdür.

amacım ,örneğin bir refarans nosunun kodu değiştiğinde sistemde bu bana bilgi olarak geliyor fakat bilgisayarımda bulunan excellerin içindeki refaransların da değiştirmem gerekiyoryardımcı olabilirseniz çok mkbule geçecek iyi günler.

[mustilem23]

Korhan Bey rica etsem inceleyebilme imkanınız var mıdır