Cautare in mai multe fisiere excel in acelasi timp

Salut. Am gasit scriptul urmator pe un site care imi cauta in toate fisierele dintr-un folder un anumit text. Puteti testa scriptul pentru a vedea exact cum functioneaza. Ceea ce vreau eu sa adaug la el este sa imi mai creeze inca o coloana (a cincea, pt ca sunt patru pana acum) care sa contina valoarea casuteti ce se afla in dreapta casuteti gasite. De exemplu am un fisier cu doua coloane de genul:
nume prenume
oncecu ion
basescu traian
iliescu ion
basescu elena

si cand rulez scriptul cautatnd dupa textul "basescu" sa imi afiseze si ceea ce se afla in casuta din dreapta (ca pana acum afiseaza doar textul gasit), adica
basescu traian
basescu elena

aici este scriptul: am gasit codul ce afiseaza rezultatele dar nu stiu cum sa preiau valoarea casutei din dreapta casutei gasite atunci cand cauta.

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
	'Change as desired
	strPath = "d:\posta\2014"
	strSearch = "burlan"
	Set wOut = Worksheets.Add
	lRow = 1
	With wOut
		.Cells(lRow, 1) = "Workbook"
		.Cells(lRow, 2) = "Worksheet"
		.Cells(lRow, 3) = "Cell"
		.Cells(lRow, 4) = "Text in Cell"
		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 "Done"
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

Cu ceva truda am aflat singur.... iata si codul in caz ca aveti nevoie de el sa va inspirati

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
	'Change as desired
	strPath = "d:\folder"
	strSearch = "cuvant"
	Set wOut = Worksheets.Add
	lRow = 1
	With wOut
		.Cells(lRow, 1) = "Fisier"
		.Cells(lRow, 2) = "Foaie"
		.Cells(lRow, 3) = "Celula"
		.Cells(lRow, 4) = "Valoare celula 1"
		.Cells(lRow, 5) = "Valoare celula 2"
		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
						'.Cells(lRow, 5) = rFound.Address() 'Row & " " & rFound.Column
						Set rFound2 = wks.UsedRange.Cells(rFound.Row, rFound.Column + 1)
						.Cells(lRow, 5) = rFound2.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 "Done"
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