Search & extract from multiple workbooks

[Guest]

I have over 20 workbooks (each with several worksheets), that I would like to
search for the character string "03-", and when it is found, copy the entire
row it is in into a separate workbook. None of the workbooks are exactly the
same, so I need to scan the entire book, including each sheet.

If I need to run a search and create a new worksheet in each file to capture
the results, then pull each new worksheet into a new workbook, I can do that.

I am using Excel 2003, not good with VBA creation but familiar with general
programming syntax. Can anyone help?

Thanks,
Ann

 

[Tom Ogilvy]

Sub copyData()
dim sh as Worksheet, sh1 as Worksheet
Dim rng as Range, rng1 as Range
dim fName as String
Dim sAddr as String
Dim bk as Workbook

' sheet to copy data to:
set sh1 = thisworkbook.Worksheets("Sheet1")

fName = Dir("C:\MyFolder\*.xls")
do while fName <> ""
set bk = Workbooks.Open("C:\Myfolder\" & fName)
for each sh in bk.Worksheets
set rng = sh.Cells.Find("03-*", Lookin:=xlValues, _
Lookat:=xlWhole,MatchCase:=False)
if not rng is nothing then
sAddr = rng.Address
do
set rng1 =sh1.Cells(rows.count,1).End(xlup)(2)
rng.EntireRow.copy Destination:=rng1
if isempty(rng1) then rng1.Value = "ZZZZXXX"
set rng = sh.Cells.FindNext(rng)
Loop rng.Address <> sAddr
end if
Next sh
fName = Dir()
Loop
End Sub


Would be a start.
Code is untested and may contain typos, but should be close.
Assumes all the workbooks are in a single directory and you want to process
all workbooks in that directory.

 

[Guest]

I am getting a "Compile Error: syntax error" for this line:
Loop rng.Address <> sAddr

Otherwise, should work ok, all workbooks are in the same directory and I
want to search all of them.

Any help? What am I missing?

Thanks,
Ann

 

[Tom Ogilvy]

Loop while rng.Address <> sAddr

 

[Tom Ogilvy]

You probably don't want all the workbooks open at the end either, so I added
a line:

Sub copyData()
Dim sh As Worksheet, sh1 As Worksheet
Dim rng As Range, rng1 As Range
Dim fName As String
Dim sAddr As String
Dim bk As Workbook

' sheet to copy data to:
Set sh1 = ThisWorkbook.Worksheets("Sheet1")

fName = Dir("C:\MyFolder\*.xls")
Do While fName <> ""
Set bk = Workbooks.Open("C:\Myfolder\" & fName)
For Each sh In bk.Worksheets
Set rng = sh.Cells.Find("03-*", LookIn:=xlValues, _
Lookat:=xlWhole, MatchCase:=False)
If Not rng Is Nothing Then
sAddr = rng.Address
Do
Set rng1 = sh1.Cells(Rows.Count, 1).End(xlUp)(2)
rng.EntireRow.Copy Destination:=rng1
If IsEmpty(rng1) Then rng1.Value = "ZZZZXXX"
Set rng = sh.Cells.FindNext(rng)
Loop While rng.Address <> sAddr
End If
Next sh
' added line to close workbook
bk.Close Savechanges:=False
fName = Dir()
Loop
End Sub

 

[Guest]

Works like a charm!

One other thing, more convenience than anything, is there a way to have it
add the originating file name to the row of data it returns?

Such as:
"FileOne.xls" "03-54345"

Thanks so much!

 

[Tom Ogilvy]

Sub copyData()
Dim sh As Worksheet, sh1 As Worksheet
Dim rng As Range, rng1 As Range
Dim fName As String
Dim sAddr As String
Dim bk As Workbook

' sheet to copy data to:
Set sh1 = ThisWorkbook.Worksheets("Sheet1")

fName = Dir("C:\MyFolder\*.xls")
Do While fName <> ""
Set bk = Workbooks.Open("C:\Myfolder\" & fName)
For Each sh In bk.Worksheets
Set rng = sh.Cells.Find("03-*", LookIn:=xlValues, _
Lookat:=xlWhole, MatchCase:=False)
If Not rng Is Nothing Then
sAddr = rng.Address
Do
Set rng1 = sh1.Cells(Rows.Count, 1).End(xlUp)(2)
rng.EntireRow.Copy Destination:=rng1
rng1.Insert Shift:=xlShifttoRight
' uncomment to get sheet name too
rng1.Offset(0,-1).Value = bk.Name ' & "!" & rng.Parent.Name
Set rng = sh.Cells.FindNext(rng)
Loop While rng.Address <> sAddr
End If
Next sh
' added line to close workbook
bk.Close Savechanges:=False
fName = Dir()
Loop
End Sub