Makro ile birden fazla kelime arama

[schlecht]

Merhaba, ekteki örnek dosyada f2 hücresine yazdığım kelimeye veya sayıyı bir klasör içindeki tüm excellerde aratıp listeleyebiliyorum. F2:F9 arası yazılan değerleri listelemek istiyorum. 8 adet aranacak değer yazmak istiyorum. yardımcı olursanız sevinirim. teşekkürler.

 

[Korhan Ayhan]

Deneyiniz.

Sub SearchFolders()
    Dim fso As Object
    Dim fld As Object
    Dim strSearch As String
    Dim strPath As String
    Dim strFile As String
    Dim wOut As Worksheet
    Dim wbk As Workbook
    Dim wks As Worksheet
    Dim lRow As Long
    Dim rFound As Range
    Dim strFirstAddress As String
    Dim Aranan As Range

    On Error GoTo ErrHandler
    Application.ScreenUpdating = False

    Set ObjFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Klasör seçin !!!", &H100)
    strPath = ObjFolder.Items.Item.Path

    Set wOut = ActiveSheet
    lRow = 1
    
    With wOut
        .Cells(lRow, 1) = "1. başlık"
        .Cells(lRow, 2) = "2. başlık"
        .Cells(lRow, 3) = "3. başlık"
        .Cells(lRow, 4) = "4. başlık"
    
        For Each Aranan In .Range("F2:F9")
            strSearch = Aranan.Value
         
            Set fso = CreateObject("Scripting.FileSystemObject")
            Set fld = fso.GetFolder(strPath)
    
            strFile = Dir(strPath & "\*.xlsm*")
            Do While strFile <> ""
                Set wbk = Workbooks.Open _
                (Filename:=strPath & "\" & strFile, _
                UpdateLinks:=0, _
                ReadOnly:=True, _
                AddToMRU:=False)
    
                For Each wks In wbk.Worksheets
                    Set rFound = wks.UsedRange.Find(strSearch)
                    If Not rFound Is Nothing Then
                        strFirstAddress = rFound.Address
                    End If
                    Do
                        If rFound Is Nothing Then
                            Exit Do
                        Else
                            lRow = lRow + 1
                            .Cells(lRow, 1) = wbk.Name
                            .Cells(lRow, 2) = wks.Name
                            .Cells(lRow, 3) = rFound.Address
                            .Cells(lRow, 4) = rFound.Value
                        End If
                        Set rFound = wks.Cells.FindNext(After:=rFound)
                    Loop While strFirstAddress <> rFound.Address
                Next
    
                wbk.Close (False)
                strFile = Dir
            Loop
            .Columns("A:D").EntireColumn.AutoFit
        Next
    End With
        
    MsgBox "İşlem Tamamladı...", vbInformation

ExitHandler:
    Set wOut = Nothing
    Set wks = Nothing
    Set wbk = Nothing
    Set fld = Nothing
    Set fso = Nothing
    Application.ScreenUpdating = True
    Exit Sub

ErrHandler:
    MsgBox Err.Description, vbExclamation
    Resume ExitHandler
End Sub

 

[schlecht]

Korhan Hocam cevabınız için teşekkürker.

For Each Aranan In Range("F2:F9") bu aralıkta aranacak kelimeleri yazıyorum fakat sadece 2 tanesini buluyor daha fazlasını bulmuyor.

 

[Korhan Ayhan]

Kodu revize ettim. Tekrar deneyiniz.

 

[schlecht]

Korhan Hocam elinize sağlık çok teşekkür ederim.