Muharrem DOĞANCI: Excel VBA İle Kapsamlı Arama

12 Şubat 2023 Pazar

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

Muharrem DOĞANCI

Bu Blogda Ara

12 Şubat 2023 Pazar

Excel VBA İle Kapsamlı Arama

Hiç yorum yok:

Yorum Gönder