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

mustilem23 · 24 Temmuz 2013

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 · 24 Temmuz 2013

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

mustilem23 · 2 Ağustos 2013

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

omerceri · 3 Ağustos 2013

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

nikferli · 3 Ağustos 2013

windows aramayı kullan

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

Korhan Ayhan · 4 Ağustos 2013

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;

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 · 19 Ocak 2015

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 · 19 Ocak 2015

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

mustilem23 · 19 Ocak 2015

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 · 20 Ocak 2015

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

Korhan Ayhan · 22 Ocak 2015

Aşağıdaki kodu deneyiniz.

Örnek Dosya

Kod:

Option Explicit

Dim Dosya As String, Aranan As Variant, Klasor As Object
Dim Hedef_Kitap As Workbook, Sayfa As Worksheet, Satir As Long
Dim K1 As Workbook, S1 As Worksheet, Bul As Range, Adres As String
Dim Alt_Klasor As Object, Alt_Dosya As Object, Zaman As Double

Sub KLASORDE_COKLU_KOD_ARAMA()
    Set Klasor = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir klasör seçiniz !", 1)
    If Klasor Is Nothing Then Exit Sub
    
    Application.ScreenUpdating = False
    
    Liste (Klasor.Items.Item.Path)
    Alt_Liste (Klasor.Items.Item.Path)
    
    S1.Range("A:E").EntireColumn.AutoFit
    
    Set Klasor = Nothing
    Set Bul = Nothing
    Set K1 = Nothing
    Set S1 = Nothing

    Application.ScreenUpdating = True
    
    If Satir > 1 Then
        MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & _
               "İşlem süresi ; " & Format(Timer - Zaman, "0.000") & " Saniye", vbInformation
    Else
        MsgBox Aranan & " numaralı kod bulunamamıştır!" & Chr(10) & _
               "İşlem süresi ; " & Format(Timer - Zaman, "0.000") & " Saniye", vbCritical
    End If
End Sub

Private Sub Liste(Yol As String)
    Set K1 = ThisWorkbook
    Set S1 = K1.Sheets("Sayfa1")
    
    Aranan = InputBox("Lütfen aradığınız kodu giriniz...", "Kod arama işlemi...")
    If Aranan = False Or Aranan = "" Then Exit Sub
    
    Zaman = Timer
    
    S1.Range("A2:E" & Rows.Count).Clear
    Dosya = Dir(Yol & "\*.xls*")
    
    While Dosya <> ""
        Set Hedef_Kitap = Workbooks.Open(Yol & "\" & 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) = Yol
                    S1.Cells(Satir, 2) = Dosya
                    S1.Cells(Satir, 3) = Sayfa.Name
                    S1.Cells(Satir, 4) = Bul.Address(False, False)
                    S1.Hyperlinks.Add Anchor:=S1.Cells(Satir, 5), _
                    Address:=Yol & "\" & Dosya, SubAddress:=Sayfa.Name & "!" & S1.Cells(Satir, 4), _
                    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
End Sub
 
Private Sub Alt_Liste(Yol As String)
    Set Alt_Klasor = CreateObject("Scripting.FileSystemObject").GetFolder(Yol).SubFolders
 
    On Error GoTo Devam
 
    For Each Alt_Dosya In Alt_Klasor
        Dosya = Dir(Alt_Dosya.Path & "\*.xls*")
        While Dosya <> ""
            DoEvents
            Set Hedef_Kitap = Workbooks.Open(Alt_Dosya & "\" & Dosya, False, False)
                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) = Alt_Dosya
                            S1.Cells(Satir, 2) = Dosya
                            S1.Cells(Satir, 3) = Sayfa.Name
                            S1.Cells(Satir, 4) = Bul.Address(False, False)
                            S1.Hyperlinks.Add Anchor:=S1.Cells(Satir, 5), _
                            Address:=Alt_Dosya & "\" & Dosya, SubAddress:=Sayfa.Name & "!" & S1.Cells(Satir, 4), _
                            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 True
            Dosya = Dir
        Wend

        Alt_Liste (Alt_Dosya.Path)
Devam:
    Next
End Sub

mustilem23 · 22 Ocak 2015

Korhan Bey ilginiz için teşekkür ederim ana klasör ve alt klasörlerde buluyor artık fakat resimde de bahsetmek istediğim gibi bulduğu yoldaki excele git dediğimde aradığım kelimenin üzerinde durmuyor aşağıdaki gibi bir uyarı veriyor .

bundan önceki makroda git dediğimde exceli açıp aradığım kelimenin üzerinde duruyor imleç ,yeni makroda da aynı özelliği ekleyebilmemiz mümkün müdür.

bulduğu
http://www.resimupload.net.tr/image.php?di=KJ0E

eski makro.
http://www.resimupload.net.tr/image.php?di=4HV5

Korhan Ayhan · 23 Ocak 2015

Örnek dosyayı ve kodu güncelledim. Tekrar deneyiniz.

mustilem23 · 23 Ocak 2015

Günaydın Korhan Bey ,

sorun giderilmiştir ilginiz için çok teşekkürler.

Hyperhysv · 7 Şubat 2015

Korhan bey merhabalar;

Bu arama işlemini aynı mantıkla .txt uzantılı dosyalarda yapmak ve dosyanızı bu şekilde modifiye etmek mümkünmü?

yani excel yerine txt uzantılı dosyalarda arama yapmak

teşekkürler
iyi çalışmalar

Hyperhysv · 8 Şubat 2015

korhan bey müsait olduğunuzda yardımcı olursanız çok sevinirim.

teşekkürler

Korhan Ayhan · 9 Şubat 2015

Ekteki dosyayı deneyiniz.

Kod:

Option Explicit

Dim Klasor As Object, Satir As Long, Zaman As Double, Aranan As Variant
Dim K1 As Workbook, S1 As Worksheet, Dosya As Variant, Dosya_Sistemi As Object
Dim Hedef_Dosya As Object, Bulunan_Satir As Long, Veri As String
Dim Alt_Klasor As Object, Alt_Dosya As Object

Sub KLASORDE_COKLU_KOD_ARAMA()
    Set Klasor = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir klasör seçiniz !", 1)
    If Klasor Is Nothing Then Exit Sub
    
    Application.ScreenUpdating = False
    
    Liste (Klasor.Items.Item.path)
    Alt_Liste (Klasor.Items.Item.path)
    
    S1.Range("A:D").EntireColumn.AutoFit
    
    Set Klasor = Nothing
    Set K1 = Nothing
    Set S1 = Nothing

    Application.ScreenUpdating = True
    
    If Satir > 1 Then
        MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & _
               "İşlem süresi ; " & Format(Timer - Zaman, "0.000") & " Saniye", vbInformation
    Else
        MsgBox Aranan & " numaralı kod bulunamamıştır!" & Chr(10) & _
               "İşlem süresi ; " & Format(Timer - Zaman, "0.000") & " Saniye", vbCritical
    End If
End Sub

Private Sub Liste(Yol As String)
    Set K1 = ThisWorkbook
    Set S1 = K1.Sheets("Sayfa1")
    
    Aranan = InputBox("Lütfen aradığınız kodu giriniz...", "Kod arama işlemi...")
    If Aranan = False Or Aranan = "" Then Exit Sub
    
    Zaman = Timer
    
    S1.Range("A2:E" & Rows.Count).Clear
    Dosya = Dir(Yol & "\*.txt*")
    
    Set Dosya_Sistemi = CreateObject("Scripting.FileSystemObject")
    
    While Dosya <> ""
        Bulunan_Satir = 0
        
        Open Yol & "\" & Dosya For Input As #1
        
        DoEvents
        
        Do Until EOF(1)
            Line Input #1, Veri
            Bulunan_Satir = Bulunan_Satir + 1
            If InStr(1, Veri, Aranan, vbTextCompare) > 0 Then
                Satir = S1.Cells(Rows.Count, 1).End(3).Row + 1
                S1.Cells(Satir, 1) = Yol
                S1.Cells(Satir, 2) = Dosya
                S1.Cells(Satir, 3) = Bulunan_Satir
                S1.Hyperlinks.Add Anchor:=S1.Cells(Satir, 4), _
                Address:=Yol & "\" & Dosya, SubAddress:="", _
                TextToDisplay:="Ulaşmak için tıklayınız..."
            End If
        Loop
        
        Close #1
        Dosya = Dir
    Wend
End Sub
 
Private Sub Alt_Liste(Yol As String)
    Set Alt_Klasor = CreateObject("Scripting.FileSystemObject").GetFolder(Yol).SubFolders
 
    On Error GoTo Devam
 
    For Each Alt_Dosya In Alt_Klasor
        Dosya = Dir(Alt_Dosya.path & "\*.txt*")
        While Dosya <> ""
            Bulunan_Satir = 0
        
            Open Alt_Dosya & "\" & Dosya For Input As #1
        
            DoEvents
        
            Do Until EOF(1)
                Line Input #1, Veri
                Bulunan_Satir = Bulunan_Satir + 1
                If InStr(1, Veri, Aranan, vbTextCompare) > 0 Then
                    Satir = S1.Cells(Rows.Count, 1).End(3).Row + 1
                    S1.Cells(Satir, 1) = Alt_Dosya
                    S1.Cells(Satir, 2) = Dosya
                    S1.Cells(Satir, 3) = Bulunan_Satir
                    S1.Hyperlinks.Add Anchor:=S1.Cells(Satir, 4), _
                    Address:=Yol & "\" & Dosya, SubAddress:="", _
                    TextToDisplay:="Ulaşmak için tıklayınız..."
                End If
            Loop

            Close #1
            Dosya = Dir
        Wend

        Alt_Liste (Alt_Dosya.path)
Devam:
    Next
End Sub

Hyperhysv · 19 Mart 2015

Sn. Korhan AYHAN açık yüreklilikle söyleyebilirim ki bence altın üyeliğin fiyatı 2 katına çıkarılmalı

teşekkürler ve iyi çalışmalar

Korhan Ayhan · 13 Haziran 2015

Ne gibi bir hata alıyorsunuz?

guven kaya · 19 Ağustos 2017

Değerli arkadaşlar bir excel tablom için resim koduna göre BAKIM FÖYLERİ klasöründen çağırabiliyorum. Ancak resimlerin bulunduğu BAKIM FÖYLERİ dizininin alt dizinlerinde de resimler var. Ekte gönderdiğim makroda alt dizinlerdekini de nasıl aratabilirim? Koda ne ilave etmem gerekiyor. Yardımcı olabilir misiniz? Teşekkürler.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim res As String
Dim a As Shape
Dim X15 As Range
If Target = "" Or Target.Address <> "$X$12" Then Exit Sub
If Target.Count > 1 Then Exit Sub
Set X15 = Range("X15")
For Each a In Shapes

DrawingObjects.Delete

Next a
X15.ClearContents
res = \\server\Users\Administrator\Desktop\WEBOSS\BAKIM FÖYLERİ\" & Target & ".jpg"[/COLOR]
If Dir(res) = "" Then
X15 = "FÖY YOK"
Else
With ActiveSheet.Pictures.Insert(res)
.Left = X15.Left
.Top = X15.Top
.Height = X15.Height
.Width = X15.Width
End With
End If
End Sub

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

mustilem23

mustilem23

mustilem23

omerceri

nikferli

Korhan Ayhan

Administrator

Ekli dosyalar

mustilem23

feridici_genc

mustilem23

mustilem23

Korhan Ayhan

Administrator

Ekli dosyalar

mustilem23

Korhan Ayhan

Administrator

mustilem23

Hyperhysv

Hyperhysv

Korhan Ayhan

Administrator

Ekli dosyalar

Hyperhysv

Korhan Ayhan

Administrator

guven kaya