Excel VBA İle Kapsamlı Arama

Kaynak: https://youtu.be/2J667D3NlIQ

Koda küçük bir yama ekledim. Dosya adını, hücre adresi ile birlikte linke dönüştürdüm. Tıkladığınızda imleç, ilgili hücreye gider.

Option Explicit Dim ws As Worksheet Dim BaslangicSatiri As Long Dim AranacakIfade As String Dim FSO As Object Public Sub Kapsamli_Ara() Dim SecilenKlasor As String BaslangicSatiri = 1 Set ws = Sonuc Set FSO = CreateObject("Scripting.FileSystemObject") With Application.FileDialog(msoFileDialogFolderPicker) If .Show = -1 Then SecilenKlasor = .SelectedItems(1) & Application.PathSeparator Else Exit Sub End If End With With ws.Cells(BaslangicSatiri, 1) .Parent.UsedRange.Clear .Offset(, 0) = "Dosya Adi" .Offset(, 1) = "Sayfa Adi" .Offset(, 2) = "Bulundugu Hucre" .Offset(, 3) = "Bulunan Deger" End With AranacakIfade = InputBox("Lutfen aranacak ifadeyi kismen veya tam olarak yaziniz", _ "Sayin" & Environ("UserName")) If Trim(AranacakIfade) = "" Then Exit Sub With Application .DisplayAlerts = False .ScreenUpdating = False .EnableEvents = False .Calculation = xlCalculationManual End With KlasorAl FSO.GetFolder(SecilenKlasor) ws.UsedRange.EntireColumn.AutoFit With Application .DisplayAlerts = True .ScreenUpdating = True .EnableEvents = True .Calculation = xlCalculationAutomatic End With ws.Activate End Sub Private Sub KlasorAl(Klasor) Dim AltKlasor Dim Dosya For Each AltKlasor In Klasor.SubFolders KlasorAl AltKlasor Next AltKlasor For Each Dosya In Klasor.Files If LCase(FSO.GetExtensionName(Dosya)) Like "*xls*" Then DosyaIsle Dosya.Path End If Next Dosya End Sub Private Sub DosyaIsle(ByVal IslenenDosya As String) Dim wb As Workbook Dim sht As Worksheet Dim rng As Range Dim cllSonuc As Range Dim bulunanIlkAdres As String Set wb = Workbooks.Open(IslenenDosya, False, True) For Each sht In wb.Sheets Set rng = sht.UsedRange Set cllSonuc = rng.Find(AranacakIfade) If Not cllSonuc Is Nothing Then bulunanIlkAdres = _ cllSonuc.Address(False, False) Do If cllSonuc Is Nothing Then Exit Do BaslangicSatiri = BaslangicSatiri + 1 With ws.Cells(BaslangicSatiri, 1) ws.Hyperlinks.Add Anchor:=ws.Cells(BaslangicSatiri, 1), _ Address:=IslenenDosya & "#'" & sht.Name & "'!" & cllSonuc.Address(False, False), _ TextToDisplay:=wb.Name .Offset(, 1) = sht.Name .Offset(, 2) = cllSonuc.Address(False, False) .Offset(, 3) = cllSonuc.Value End With Set cllSonuc = rng.FindNext(cllSonuc) Loop While bulunanIlkAdres <> cllSonuc.Address(False, False) Next sht wb.Close False End Sub 'Kaynak: _ https://youtu.be/2J667D3NlIQ 'Mehmet CANBULAT