Search & extract from multiple workbooks

  • Thread starter Thread starter Guest
  • Start date Start date
G

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
 
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.
 
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
 
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
 
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!
 
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
 
Back
Top