copying information from various excel files

M

Marcelo P.

HELP PLEASE!!!

I need your help with the following situation:

I have multiple excel files that have the same exact structure.
Have to search across all of the files for two different strings,
which should both be prompted (stra and strb).
This information prompted should be compared, (stra) with the values
in column c (if this is true), then strb with the values in column d.


If both criterias are located in the SAME row, I have to display the
information on columns e and f.

Thanks to all of you for your help.

Marcelo
 
D

Dave Peterson

This might work for you if all your workbooks are in the same folder.

It looks at each sheet in each workbook. But I'm not sure what to do with it
after I find the stuff. So I just leave them open--I don't close them, I don't
save them.

And strA and strB have to be the only thing in the cell.

If you decide to update the workbooks with the changes, I'd copy all the
workbooks to a dedicated folder. Then run this macro against that folder.
(Click on the first and shift-click on the last when you get the File|open
dialog).

Then if anything goes wrong, your original workbooks will still be ok.

anyway...

Option Explicit
Sub testme()

Dim newWks As Worksheet
Dim myFileNames As Variant
Dim nextWkbk As Workbook
Dim wks As Worksheet
Dim fCtr As Long
Dim FirstAddress As String
Dim FoundCell As Range
Dim strA As String
Dim strB As String

strA = InputBox(Prompt:="What's stringA?")
If strA = "" Then
Exit Sub
End If

strB = InputBox(Prompt:="What's stringA?")
If strB = "" Then
Exit Sub
End If

myFileNames = Application.GetOpenFilename _
(FileFilter:="Excel files, *.xls", _
MultiSelect:=True)

If IsArray(myFileNames) Then
Application.ScreenUpdating = False
For fCtr = LBound(myFileNames) To UBound(myFileNames)
Set nextWkbk = Nothing
On Error Resume Next
Set nextWkbk = Workbooks.Open(Filename:=myFileNames(fCtr))
On Error GoTo 0
If nextWkbk Is Nothing Then
MsgBox "Error with: " & myFileNames(fCtr)
Else
For Each wks In nextWkbk.Worksheets
FirstAddress = ""
With wks.Range("c:C")
Set FoundCell = .Cells.Find(what:=strA, _
LookIn:=xlValues, lookat:=xlWhole, _
searchdirection:=xlNext, _
after:=.Cells(.Cells.Count))
If Not FoundCell Is Nothing Then
FirstAddress = FoundCell.Address
Do
If wks.Cells(FoundCell.Row, "D").Value _
= strB Then
wks.Cells(FoundCell.Row, "E").Value = strA
wks.Cells(FoundCell.Row, "F").Value = strB
End If
Set FoundCell = .FindNext(FoundCell)
Loop While Not FoundCell Is Nothing _
And FoundCell.Address <> FirstAddress
End If
End With
Next wks
'save the workbook?
'nextWkbk.Save

'or close and save?
'nextWkbk.Close savechanges:=True

'or do nothing and just leave it open
End If
Next fCtr
Else
MsgBox "try again later!"
End If

Application.ScreenUpdating = True

End Sub
 
Top