Jump to content

SUBIECTE NOI
« 1 / 5 »
RSS
Info Coronavirus/Vaccinare vs Fake News

La multi ani @sfantu.dracu!

Indiana Jones and the Dial of Des...

Ariston Genus One 24kw - sa o aru...
 Robot smart cu comanda vocala goo...

Moduri de a evita anumite persoane

Panouri pe acoperis cu horn

Transformers: Rise of the Beasts ...
 Hatufim - Prizonieri de razboi

Receiver AV 8K

rog un pic de ajutor in legatura ...

Ce defect sa fie ( centrala nu at...
 Jocuri - Generals si Generals Zer...

Video Night mode

Mp5 player auto

Nu-mi vede pc-ul telefonul
 

Cautare in mai multe fisiere excel in acelasi timp

- - - - -
  • Please log in to reply
1 reply to this topic

#1
inginerule

inginerule

    Active Member

  • Grup: Members
  • Posts: 1,353
  • Înscris: 19.09.2013
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




#2
inginerule

inginerule

    Active Member

  • Grup: Members
  • Posts: 1,353
  • Înscris: 19.09.2013
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




Anunturi

Bun venit pe Forumul Softpedia!

0 user(s) are reading this topic

0 members, 0 guests, 0 anonymous users

Forumul Softpedia foloseste "cookies" pentru a imbunatati experienta utilizatorilor Accept
Pentru detalii si optiuni legate de cookies si datele personale, consultati Politica de utilizare cookies si Politica de confidentialitate