Cautare text in fisiere multiple

Sursa: http://excel.tips.net/T005598_Searching_Through_Many_Workbooks.html

Presupunem că avem un folder care conţine sute de fișiere Excel și trebuie să căutăm în fiecare fișier un anumit text.

Executând macrocomanda, VBA va adăuga o foaie de lucru nouă în fișierul din care este executat și în foaie va afişa un tabel cu fișierele, foile de lucru, celulele și conținutul celulelor cu textul căutat.

Macrocomanda va deschide doar fişierele cu extensia xls* (asteriscul este pentru fişierele de tip xls, xlsx, și xlsm).

COPIEREA RAPIDĂ A CODULUI ÎN VBA

Se copie codul de mai jos (selecție și Ctrl+C).

În fișierul Excel se apasă Alt+F11 (Excel va deschide aplicația VBA), apoi se apasă tasta F7 (pentru a comuta la fereastra Code).

Aici se poate insera codul copiat (cu Ctrl+V).

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

On Error GoTo ErrHandler

Application.ScreenUpdating = False

'---linia urmatoare se modifică cu calea la folder

strPath = "c:\MyFolder"

'---linia urmatoare se modifică cu textul care va fi căutat

strSearch = "Aici, textul de cautat"

Set wOut = Worksheets.Add

lRow = 1

With wOut

.Cells(lRow, 1) = "Fisier Excel"

.Cells(lRow, 2) = "Foaie de lucru"

.Cells(lRow, 3) = "Celula"

.Cells(lRow, 4) = "Textul cautat"

Set fso = CreateObject("Scripting.FileSystemObject")

Set fld = fso.GetFolder(strPath)

strFile = Dir(strPath & "\*.xls*")

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

End With

MsgBox "Am terminat :)"

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