hücredeki ifadeyi klasördeki pdf dosyalarının içinde aramakla ilgili

[mekist]

Deneyiniz.

Bahsettiğiniz çoklu arama işlemindeki süreyide bildirirseniz sevinirim.

Option Explicit

Sub Find_Text_in_Selected_Folder()
    Dim S1 As Worksheet, Process_Time As Double
    Dim My_Folder As Variant, Source_Folder As String
    Dim Find_Text As String, Last_Row As Long
    Dim Search_Data As Variant, X As Long
    Dim My_Connection As Object, My_Recordset As Object
    Dim My_Query As String, Y As Byte
   
    Set S1 = Sheets("Sayfa1")
   
    If WorksheetFunction.CountA(S1.Range("A:A")) = 0 Then
        MsgBox "İşleme devam edebilmek için A sütununa aramak istediğiniz kelimeleri yazmalısınız!", vbCritical
        Set S1 = Nothing
        Exit Sub
    End If
   
    Set My_Folder = CreateObject("Shell.Application").BrowseForFolder(0, "Kaynak dosyaları içeren klasörü seçiniz...", 50, &H0)

    If My_Folder Is Nothing Then
        MsgBox "İşleme devam edebilmek için klasör seçimi yapmalısınız!" & Chr(10) & _
               "İşleminiz iptal edilmiştir.", vbCritical
        Exit Sub
    ElseIf My_Folder = "Masaüstü" Or My_Folder = "Desktop" Then
        Source_Folder = Environ("UserProfile") & "\Desktop\"
    ElseIf Not My_Folder Is Nothing Then
        Source_Folder = My_Folder.Items.Item.Path
    End If
   
    Process_Time = Timer
   
    Application.ScreenUpdating = False
   
    Set My_Connection = CreateObject("AdoDb.Connection")
    Set My_Recordset = CreateObject("AdoDb.Recordset")
   
    My_Connection.Open "Provider=Search.CollatorDSO;" & _
                       "Extended Properties='Application=Windows';"
       
    S1.Range("D:F").Clear
    Last_Row = 1
   
    Search_Data = S1.Range("A1:A" & WorksheetFunction.Max(2, S1.Cells(S1.Rows.Count, 1).End(3).Row)).Value
   
    For X = LBound(Search_Data) To UBound(Search_Data)
        If Search_Data(X, 1) <> "" Then
            Find_Text = Search_Data(X, 1)
       
            My_Recordset.Open "Select System.ItemName, System.ItemFolderPathDisplay " & _
                              " From SystemIndex" & _
                              " Where Scope = 'File:" & Source_Folder & "' " & _
                              " And Contains('" & Replace(Find_Text, " ", "?") & "')", My_Connection
           
            If Not My_Recordset.EOF Then
                My_Recordset.MoveFirst
                Do Until My_Recordset.EOF
                    With My_Recordset.Fields
                        S1.Cells(Last_Row, "D") = .Item("System.ItemFolderPathDisplay")
                        S1.Cells(Last_Row, "E") = .Item("System.ItemName")
                        S1.Cells(Last_Row, "F") = Find_Text
                        S1.Hyperlinks.Add Anchor:=S1.Cells(Last_Row, "E"), _
                        Address:=S1.Cells(Last_Row, "D").Value & _
                        Application.PathSeparator & S1.Cells(Last_Row, "E").Value, _
                        TextToDisplay:=S1.Cells(Last_Row, "E").Value
                        Last_Row = Last_Row + 1
                    End With
                    My_Recordset.MoveNext
                Loop
            End If
       
            My_Recordset.Close
        End If
    Next
       
    Columns("D:F").AutoFit
   
    My_Connection.Close
   
    Set S1 = Nothing
    Set My_Folder = Nothing
    Set My_Recordset = Nothing
    Set My_Connection = Nothing

    Application.ScreenUpdating = True
   
    MsgBox "İşleminiz tamamlanmıştır." & vbCrLf & vbCrLf & _
           "İşlem süresi ; " & Format(Timer - Process_Time, "0.00") & " Saniye", vbInformation
End Sub

Korhan Hocam Merhaba
Bunu eklenti yapmak mümkün mü

 

[Korhan Ayhan]

Nasıl bir eklentiyi kast ettiğinize bağlı..

 

[mekist]

Sağ klik menüsüne eklemek gibi, amaç her dosyada kullanılabilir bir yapı

 

[Korhan Ayhan]

Forumda daha önce paylaşılan sağ klik eklentilerine bakarak yapabilirsiniz. Bolca örnek var.