metin parçasına göre pc de arama

[modoste]

merhaba sayın hocalarım
daha önce bilgisayardaki klasörlerden dosya isimlerini sıralamak gibi makro ile çözümler üretilmişti forumumuzdan
şu an için istediğim ise (1-2 program indirip arama yapsamda yavaşlık olduğundan);
excelde yapılacak makro ile dosya adına göre değil de dosyaların içinde (word olur excel olur) geçen metin parçasına göre arama yapabilir mi excel programı

daha önce ben bu ifadeyi bir excel dosyamda vardı diye arayp arayıp duruyorum dosyaları ama metin parçasın içinde geçtiğinden imkansız gibi birşey
filelocatör ve agent ransack gibi programları indirip kullanıyorum ama arama bulma işleri çok yavaş oluyo

 

[KuTuKa]

Merhaabalar

alt+f11
insert Module yapıp aşağıdaki makroyu kopyalayın.eccele geçip alt+f8 ile makroyu çalıştırın. Bence işinizi görür.

İyi Çalışmalar





Option Explicit


' ==== KULLANICI AYARLARI ====
' Bu değerleri isterseniz makro başında değiştirebilir veya InputBox ile alabilirsiniz.
Private Const DEFAULT_SEARCH_TEXT As String = "aranan metin"
Private Const DEFAULT_FOLDER_PATH As String = "C:\AranacakKlasor"
Private Const INCLUDE_SUBFOLDERS As Boolean = True
Private Const CASE_SENSITIVE As Boolean = False
Private Const WHOLE_WORD As Boolean = False
' Excel için: değerlerde (xlValues) ve formüllerde (xlFormulas) arama
Private Const SEARCH_IN_VALUES As Boolean = True
Private Const SEARCH_IN_FORMULAS As Boolean = False
' ==== ANA MAKRO ====
Public Sub SearchTextInDocuments()
Dim searchText As String
Dim folderPath As String
Dim wsOut As Worksheet
Dim nextRow As Long
Dim tStart As Double

' Kullanıcıdan girdiler (isteğe bağlı)
searchText = Application.InputBox("Aranacak metin parçası:", "Arama", DEFAULT_SEARCH_TEXT, Type:=2)
If searchText = "False" Or Len(searchText) = 0 Then Exit Sub

folderPath = Application.InputBox("Klasör yolu:", "Arama Klasörü", DEFAULT_FOLDER_PATH, Type:=2)
If folderPath = "False" Or Len(folderPath) = 0 Then Exit Sub
If Right(folderPath, 1) = "\" Then
' OK
Else
folderPath = folderPath & "\"
End If

' Çıkış sayfasını hazırla
Set wsOut = PrepareOutputSheet("AramaSonuçları")
wsOut.Range("A1:E1").Value = Array("Dosya Yolu", "Tür", "Konum", "Bağlam", "Eşleşme Sayısı")
nextRow = 2

' Performans ayarları
tStart = Timer
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

' Dosyaları gez
Dim fso As Object, folder As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FolderExists(folderPath) Then
MsgBox "Klasör bulunamadı: " & folderPath, vbExclamation
GoTo Cleanup
End If
Set folder = fso.GetFolder(folderPath)

' Excel uygulaması zaten biziz; Word uygulamasını tek instance olarak açalım
Dim wordApp As Object
On Error Resume Next
Set wordApp = GetObject(Class:="Word.Application")
If wordApp Is Nothing Then Set wordApp = CreateObject("Word.Application")
On Error GoTo 0
wordApp.Visible = False

' Klasör ve alt klasörler
ProcessFolder folder, searchText, wsOut, nextRow, wordApp
If INCLUDE_SUBFOLDERS Then
Dim subFolder As Object
For Each subFolder In folder.SubFolders
ProcessFolder subFolder, searchText, wsOut, nextRow, wordApp
Next subFolder
End If

Cleanup:
' Word'i kapatma (kullanıldıysa)
On Error Resume Next
If Not wordApp Is Nothing Then
wordApp.Quit SaveChanges:=False
Set wordApp = Nothing
End If
On Error GoTo 0

' Performans ayarlarını geri al
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.ScreenUpdating = True

' Basit özet
wsOut.Columns.AutoFit
MsgBox "Arama tamamlandı. Bulunan kayıt sayısı: " & (nextRow - 2) & vbCrLf & _
"Süre (sn): " & Format(Timer - tStart, "0.0"), vbInformation
End Sub
' ==== KLASÖR İŞLEME ====
Private Sub ProcessFolder(ByVal folderObj As Object, ByVal searchText As String, _
ByVal wsOut As Worksheet, ByRef nextRow As Long, ByVal wordApp As Object)
Dim fileObj As Object
For Each fileObj In folderObj.Files
Dim ext As String: ext = LCase$(fsoGetExtension(fileObj.Name))
Select Case ext
Case "xlsx", "xlsm", "xls"
SearchInExcelFile fileObj.Path, searchText, wsOut, nextRow
Case "docx", "doc"
SearchInWordFile fileObj.Path, searchText, wsOut, nextRow, wordApp
Case Else
' diğer uzantılar atlanır
End Select
DoEvents
Next fileObj
End Sub
' ==== EXCEL İÇİN ARAMA ====
Private Sub SearchInExcelFile(ByVal filePath As String, ByVal searchText As String, _
ByVal wsOut As Worksheet, ByRef nextRow As Long)
On Error GoTo SafeExit
Dim wb As Workbook
Set wb = Workbooks.Open(Filename:=filePath, ReadOnly:=True, UpdateLinks:=False)

Dim sht As Worksheet, matchCount As Long
For Each sht In wb.Worksheets
' İsteğe bağlı: UsedRange daraltması
Dim rng As Range
Set rng = sht.UsedRange
If rng Is Nothing Then GoTo NextSheet

' Values içinde arama
If SEARCH_IN_VALUES Then
matchCount = matchCount + FindAllOccurrences(rng, searchText, _
lookIn:=xlValues, wsOut:=wsOut, nextRow:=nextRow, filePath:=filePath, locationLabel:=sht.Name)
End If

' Formüller içinde arama
If SEARCH_IN_FORMULAS Then
matchCount = matchCount + FindAllOccurrences(rng, searchText, _
lookIn:=xlFormulas, wsOut:=wsOut, nextRow:=nextRow, filePath:=filePath, locationLabel:=sht.Name)
End If
NextSheet:
Next sht

SafeExit:
On Error Resume Next
If Not wb Is Nothing Then wb.Close SaveChanges:=False
End Sub
Private Function FindAllOccurrences(ByVal rng As Range, ByVal searchText As String, _
ByVal lookIn As XlFindLookIn, ByVal wsOut As Worksheet, ByRef nextRow As Long, _
ByVal filePath As String, ByVal locationLabel As String) As Long

Dim firstAddress As String
Dim foundCell As Range
Dim matchCount As Long
Dim lookAtMode As XlLookAt: lookAtMode = IIf(WHOLE_WORD, xlWhole, xlPart)
Dim searchOrder As XlSearchOrder: searchOrder = xlByRows

Set foundCell = rng.Find(What:=searchText, LookIn:=lookIn, LookAt:=lookAtMode, _
SearchOrder:=searchOrder, SearchDirection:=xlNext, _
MatchCase:=CASE_SENSITIVE)
If Not foundCell Is Nothing Then
firstAddress = foundCell.Address
Do
matchCount = matchCount + 1

' Bağlam: bulunduğu hücrenin metni (kısaltalım)
Dim snippet As String
snippet = CStr(foundCell.Text)
If Len(snippet) > 200 Then snippet = Left$(snippet, 200) & "…"

wsOut.Cells(nextRow, 1).Value = filePath
wsOut.Cells(nextRow, 2).Value = "Excel"
wsOut.Cells(nextRow, 3).Value = locationLabel & "!" & foundCell.Address(False, False)
wsOut.Cells(nextRow, 4).Value = snippet
wsOut.Cells(nextRow, 5).Value = 1 ' tek tek yazıyoruz; toplamı sheet bazında ayrıca hesaplanabilir
nextRow = nextRow + 1

Set foundCell = rng.FindNext(foundCell)
Loop While Not foundCell Is Nothing And foundCell.Address <> firstAddress
End If

FindAllOccurrences = matchCount
End Function
' ==== WORD İÇİN ARAMA ====
Private Sub SearchInWordFile(ByVal filePath As String, ByVal searchText As String, _
ByVal wsOut As Worksheet, ByRef nextRow As Long, _
ByVal wordApp As Object)
On Error GoTo SafeExit
Dim doc As Object
Set doc = wordApp.Documents.Open(filePath, ReadOnly:=True, AddToRecentFiles:=False)

Dim rng As Object
Set rng = doc.Content

With rng.Find
.Text = searchText
.MatchCase = CASE_SENSITIVE
.MatchWholeWord = WHOLE_WORD
.Forward = True
.Wrap = 1 ' wdFindContinue
.Format = False
End With

Dim matchCount As Long
Do While rng.Find.Execute
matchCount = matchCount + 1

' Bağlam snippet: eşleşme çevresinden ~160 karakter
Dim fullText As String: fullText = rng.Text
Dim snippet As String: snippet = Trim$(fullText)
If Len(snippet) > 160 Then snippet = Left$(snippet, 160) & "…"

wsOut.Cells(nextRow, 1).Value = filePath
wsOut.Cells(nextRow, 2).Value = "Word"
wsOut.Cells(nextRow, 3).Value = "Belge İçeriği"
wsOut.Cells(nextRow, 4).Value = snippet
wsOut.Cells(nextRow, 5).Value = 1
nextRow = nextRow + 1

' Sonraki arama için aralığı ilerlet
rng.Start = rng.Start + rng.Length
rng.End = doc.Content.End
Loop

SafeExit:
On Error Resume Next
If Not doc Is Nothing Then doc.Close SaveChanges:=False
End Sub
' ==== YARDIMCILAR ====
Private Function PrepareOutputSheet(ByVal sheetName As String) As Worksheet
Dim ws As Worksheet
On Error Resume Next
Set ws = ThisWorkbook.Worksheets(sheetName)
On Error GoTo 0
If ws Is Nothing Then
Set ws = ThisWorkbook.Worksheets.Add
ws.Name = sheetName
Else
ws.Cells.Clear
End If
Set PrepareOutputSheet = ws
End Function
Private Function fsoGetExtension(ByVal fileName As String) As String
Dim p As Long: p = InStrRev(fileName, ".")
If p > 0 Then
fsoGetExtension = Mid$(fileName, p + 1)
Else
fsoGetExtension = ""
End If
End Function

 

[modoste]

kulandım ama yavaş çalışıyo ve arama tamamlanmıyo kitleniyo pc
sürücüyü D: seçitğim için mi acaba 500 gb lık br alanda arıyo