Is there a neat macro out there that will copy and paste all instances
of a specified word in a worksheet into another workbook? Right now I
am using the macro below, which I have to do by hand and I always end
up with the search going back to the beginning and copying the first
instance again.

Sub coopy()
'
' coopy Macro
' Macro recorded 1/3/2006 by L Cloutier
'
' Keyboard Shortcut: Option+Cmd+e
'
Cells.FindNext(After:=ActiveCell).Activate ' this finds the next
instance of the word I'm looking for
ActiveCell.Offset(0, -1).Range("A1:C1").Select ' selects adjacent
cells
ActiveCell.Activate
Selection.Copy
Windows("meta.xls").Activate ' switches to another workbook
ActiveSheet.Paste
ActiveCell.Offset(1, 0).Range("A1").Select
Windows("HIERARCH.xls").Activate
Application.CutCopyMode = False
ActiveCell.Offset(1, 0).Range("A1").Select
End Sub

Option Compare Text
'Gary L. Brown
'Kinneson Consulting
'
'Version 1a: 01/2000 - ranges included in search
'Version 2.0: 03/21/2000 - names of sheets included in search
'Version 3.0: 04/20/2000 - DrawingObjects included in search
' Note: V3.0 DrawingObjects methodology
' STRONGLY influenced by
' Bill Manville's FindLink.xla
'Version 3.1: 06/06/2000 for recognition of ErrorTypes
'Version 3.2: 06/14/2000 - account for mis-formatting
' when there are hidden sheets
'Version 3.3: 07/06/2000 - add hyperlink to addresses
'Version 3.4: 07/27/2000 - add columns separating
' Address into Col and Row
'
Const constVersion = "3.4"
'/===============================================/
Public Sub SearchFinder()
On Error Resume Next
'Purpose of this VBA program is to find and list all
'searched for items in a Workbook
'
' For use with EXCEL 97 or higher
'

Dim aryHiddensheets()
Dim bTrueFalse1 As Boolean, bTrueFalse As Boolean
Dim iRow As Long, iColumn As Long, dblLastRow
Dim iFormulaCount As Long, iTextValuesCount As Long
Dim i As Long, iErrorTest As Long
Dim x As Long, y As Long, iWorksheets As Long
Dim nName As Name
Dim objOutputArea As Object, objCell As Object
Dim objRangeWithTextAndValues As Object, objSheet As Object
Dim objRangeWithFormulas As Object, obj As Object
Dim strInputQuestion As String
Dim strResultsTableName As String
Dim strWorksheetName As String, strWorksheetType As String
Dim strCellAddress As String, strAnswer As String
Dim strAnswer1 As String, strAnswer2 As String
Dim strStatusBarMsg1 As String, strStatusBarMsg2 As String
Dim varAnswer As Variant, varCellFormula As Variant
Dim varLookFor As Variant, varLookFor_Original As Variant
Dim varErrorTest As Variant

strResultsTableName = "Search_Results"
strStatusBarMsg1 = "Please wait...Search is in progress..."
strStatusBarMsg2 = "Please wait...Formatting results..."
strInputQuestion = "What are you Looking for?" & vbCr & _
"To find references to other spreadsheets, type " & _
Chr(34) & ".xls" & Chr(34) & vbCr & _
"To review other " & Chr(39) & "Errors" & Chr(39) & _
", try:" & vbCr & _
"#N/A or #NAME? or #REF! or #VALUE! or #DIV/0! or " & _
"#NULL! or #NUM!"

'get last search request saved to registry
strAnswer1 = _
GetSetting(APPNAME:="SearchFor", section:="Entry", _
Key:="Hour")
strAnswer2 = _
GetSetting(APPNAME:="SearchFor", section:="Entry", _
Key:="Value")
If Val(strAnswer1) < Hour(Now) - 2 Or _
Len(strAnswer2) = 0 Then
strAnswer = ".xls"
Else
strAnswer = strAnswer2
End If

varLookFor_Original = _
Application.InputBox(strInputQuestion, _
"Search and List - V. " & constVersion, strAnswer)
varLookFor = UCase(varLookFor_Original)

If varLookFor_Original = False Then
Exit Sub
End If

strInputQuestion = _
"You have not entered anything." & Chr(10) _
& Chr(10) & _
"Note: Continuing will list ALL information in " & _
"ALL worksheets in the workbook." & _
Chr(10) & Chr(10) & _
"Press Ctrl-Break at any time to break " & _
"out of this program." & _
Chr(10) & Chr(10) & _
"Do you wish to continue?"


If Len(varLookFor) = 0 Then
varAnswer = MsgBox(strInputQuestion, _
vbInformation + vbYesNo + vbDefaultButton2, _
"This could be a VERY lengthy process...!!!")

If varAnswer = vbNo Then
Exit Sub
End If
End If

On Error Resume Next

strAnswer = varLookFor

'put search value in registry
SaveSetting _
APPNAME:="SearchFor", section:="Entry", Key:="Value", _
setting:=strAnswer
SaveSetting _
APPNAME:="SearchFor", section:="Entry", Key:="Hour", _
setting:=Hour(Now)

On Error GoTo 0

Application.StatusBar = strStatusBarMsg1

'check for an active workbook
If ActiveWorkbook Is Nothing Then
'no workbooks open, so create one
Workbooks.Add
End If

'Count number of worksheets in workbook
iWorksheets = ActiveWorkbook.Sheets.Count

'redim array
ReDim aryHiddensheets(1 To iWorksheets)

'put hidden sheets in an array, then unhide the sheets
' For x = 1 To iWorksheets
' If Worksheets(x).Visible = False Then
' aryHiddensheets(x) = Worksheets(x).Name
' Worksheets(x).Visible = True
' End If
' Next
x = 0
y = 0
For Each objSheet In ActiveWorkbook.Sheets
y = y + 1
If objSheet.Visible < True Then
x = x + 1
aryHiddensheets(x) = objSheet.Name
objSheet.Visible = True
End If
Next objSheet

'Check for duplicate Worksheet name
i = ActiveWorkbook.Sheets.Count
For Each objSheet In ActiveWorkbook.Sheets
If Windows.Count = 0 Then Exit Sub
If UCase(objSheet.Name) = UCase(strResultsTableName) Then
objSheet.Activate
If Err.Number = 9 Then
Exit For
End If
Application.DisplayAlerts = False 'turn warnings off
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True 'turn warnings on
End If
Next

'Add new worksheet at end of workbook
' where results will be located
Worksheets.Add.Move After:=Worksheets(Worksheets.Count)

'Name the new worksheet and set up Titles
ActiveWorkbook.ActiveSheet.Name = strResultsTableName
ActiveWorkbook.ActiveSheet.Range("A1").Value = "Worksheet"
ActiveWorkbook.ActiveSheet.Range("B1").Value = "Address"
ActiveWorkbook.ActiveSheet.Range("C1").Value = "Col"
ActiveWorkbook.ActiveSheet.Range("D1").Value = "Row"
ActiveWorkbook.ActiveSheet.Range("E1").Value = "Type"
ActiveWorkbook.ActiveSheet.Range("F1").Value = _
"Results Found"
ActiveWorkbook.ActiveSheet.Range("G1").Value = "Value"


'Count number of worksheets in workbook
iWorksheets = ActiveWorkbook.Sheets.Count

'Initialize row and column counts for putting info into
' strResultsTableName sheet
iRow = 1
iColumn = 0

'Check Sheet names
For x = 1 To iWorksheets
Sheets(x).Activate
strWorksheetName = ActiveSheet.Name
strWorksheetType = UCase(TypeName(ActiveSheet))

If UCase(ActiveSheet.Name) = _
UCase(strResultsTableName) Then
Exit For
End If

'check to see if a match exists for sheet names
Set objOutputArea = _
ActiveWorkbook.Sheets(strResultsTableName).Range(" A1")
With objOutputArea
If InStr(UCase(strWorksheetName), varLookFor) < 0 Then
'put information into StrResultstablename worksheet
.Offset(iRow, iColumn) = " " & ActiveSheet.Name
.Offset(iRow, iColumn + 1) = ""
.Hyperlinks.Add Anchor:=.Offset(iRow, iColumn), _
Address:="", SubAddress:=Chr(39) & _
ActiveSheet.Name & _
Chr(39) & "!A1"
.Offset(iRow, iColumn + 2) = " "
.Offset(iRow, iColumn + 3) = " "
.Offset(iRow, iColumn + 4) = "W"
.Offset(iRow, iColumn + 5) = " "
Select Case strWorksheetType
Case "CHART"
.Offset(iRow, iColumn + 6) = " Note: CHART"
Case "WORKSHEET"
.Offset(iRow, iColumn + 6) = " Note: WORKSHEET"
Case "DIALOGSHEET"
.Offset(iRow, iColumn + 6) = " Note: DialogSheet"
Case Else
.Offset(iRow, iColumn + 6) = " Note: Type Unknown"
End Select
iRow = iRow + 1
End If
End With

If iRow = 65536 Then
iColumn = iColumn + 8
iRow = 1
End If

Next x

'Go through one Worksheet at a time
For x = 1 To iWorksheets
'Go to Next Worksheet
Worksheets(x).Activate
'Initialize formula and text/value count variables
iFormulaCount = 0
iTextValuesCount = 0

If ActiveWorkbook.ActiveSheet.Name < _
strResultsTableName Then
'Identify cells with formulas and text/values in them
Set objRangeWithTextAndValues = Nothing
Set objRangeWithFormulas = Nothing
'Establish cells with formulas and text/values in them
On Error Resume Next
Set objRangeWithTextAndValues = _
ActiveSheet.Cells.SpecialCells(xlTextValues)
Set objRangeWithFormulas = _
ActiveSheet.Cells.SpecialCells(xlFormulas)

iFormulaCount = objRangeWithFormulas.Count
iTextValuesCount = objRangeWithTextAndValues.Count

'if there is text
If iTextValuesCount < 0 Then
'Process each cell with a value or text in it
Set objOutputArea = _
ActiveWorkbook.Sheets(strResultsTableName).Range(" A1")
For Each objCell In objRangeWithTextAndValues
With objOutputArea
'check to see if a match exists
If InStr(UCase(objCell.Formula), _
varLookFor) < 0 Then
'put information into StrResultstablename
' Worksheet
.Offset(iRow, iColumn) = " " & ActiveSheet.Name
.Offset(iRow, iColumn + 1) = _
objCell.AddressLocal(rowabsolute:=False, _
columnabsolute:=False)
strCellAddress = _
objCell.AddressLocal(rowabsolute:=False, _
columnabsolute:=False)
.Hyperlinks.Add _
Anchor:=.Offset(iRow, iColumn + 1), _
Address:="", SubAddress:=Chr(39) & _
ActiveSheet.Name & _
Chr(39) & "!" & _
objCell.AddressLocal(rowabsolute:=False, _
columnabsolute:=False)
.Offset(iRow, iColumn + 2) = _
funcCol(strCellAddress)
.Offset(iRow, iColumn + 3) = _
funcRow(strCellAddress)
.Offset(iRow, iColumn + 4) = "V"
.Offset(iRow, iColumn + 5) = " " & _
objCell.Formula
.Offset(iRow, iColumn + 6) = " " & _
objCell.Value
iRow = iRow + 1
End If

End With

If iRow = 65536 Then
iColumn = iColumn + 8
iRow = 1
End If

Next objCell

End If

'if there are formulas
If iFormulaCount < 0 Then
'Process each cell with a value or text in it
Set objOutputArea = _
ActiveWorkbook.Sheets(strResultsTableName).Range(" A1")
For Each objCell In objRangeWithFormulas
With objOutputArea
'check to see if a match exists
' capture numeric, alpha values and errors from
' formulas
varErrorTest = ErrorType(objCell.Value)
iErrorTest = 0
If InStr(UCase(objCell.Formula), _
varLookFor) < 0 Then iErrorTest = 1
If InStr(UCase(varErrorTest), _
varLookFor) < 0 Then iErrorTest = 2
If Len(varErrorTest) = 0 Then
If InStr(UCase(objCell.Value), _
varLookFor) < 0 Then
iErrorTest = 1
End If
End If
If InStr(UCase(objCell.Value), _
varLookFor) < 0 Then
If IsError(InStr(UCase(objCell.Value), _
varLookFor)) Then
If iErrorTest < 1 And _
iErrorTest < 2 Then _
iErrorTest = 0
End If
End If
If iErrorTest < 0 Then
'put information into StrResultsTableName
' Worksheet
.Offset(iRow, iColumn) = " " & ActiveSheet.Name
.Offset(iRow, iColumn + 1) = _
objCell.AddressLocal(rowabsolute:=False, _
columnabsolute:=False)
strCellAddress = _
objCell.AddressLocal(rowabsolute:=False, _
columnabsolute:=False)
.Hyperlinks.Add _
Anchor:=.Offset(iRow, iColumn + 1), _
Address:="", SubAddress:=Chr(39) & _
ActiveSheet.Name & _
Chr(39) & "!" & _
objCell.AddressLocal(rowabsolute:=False, _
columnabsolute:=False)
.Offset(iRow, iColumn + 2) = _
funcCol(strCellAddress)
.Offset(iRow, iColumn + 3) = _
funcRow(strCellAddress)
.Offset(iRow, iColumn + 4) = "F"
.Offset(iRow, iColumn + 5) = " " & _
objCell.Formula
If UCase(varErrorTest) = "" Then
.Offset(iRow, iColumn + 6) = " " & _
objCell.Value
Else
.Offset(iRow, iColumn + 6) = " " & _
varErrorTest
End If
iRow = iRow + 1
End If
End With

If iRow = 65536 Then
iColumn = iColumn + 8
iRow = 1
End If
varErrorTest = ""
Next objCell

End If


End If

If ActiveWorkbook.ActiveSheet.Name < _
strResultsTableName Then
For Each obj In ActiveSheet.DrawingObjects
' any drawing object
If InStr(obj.OnAction, varLookFor) 0 Then
With objOutputArea
'check to see if a match exists
'put information in StrResultsTableName worksheet
.Offset(iRow, iColumn) = " " & ActiveSheet.Name
.Offset(iRow, iColumn + 1) = _
" On Action of " & obj.Name
.Offset(iRow, iColumn + 2) = " "
.Offset(iRow, iColumn + 3) = " "
.Offset(iRow, iColumn + 4) = "O"
.Offset(iRow, iColumn + 5) = " " & obj.OnAction
.Offset(iRow, iColumn + 6) = ""
iRow = iRow + 1
End With
If iRow = 65536 Then
iColumn = iColumn + 8
iRow = 1
End If
End If
' some drawing objects have formula properties
bTrueFalse = False 'Have not reviewed this object yet
Select Case TypeName(obj)
Case "TextBox", "Picture", "Button", "Label"
bTrueFalse = False
If TypeName(obj) < "Label" Then
If InStr(obj.Formula, varLookFor) 0 Then
bTrueFalse = True
With objOutputArea
'check to see if a match exists
'put information into
' strResultsTableName Worksheet
.Offset(iRow, iColumn) = " " & _
ActiveSheet.Name
.Offset(iRow, iColumn + 1) = _
" Formula in " & TypeName(obj) _
& " - " & obj.Name
.Offset(iRow, iColumn + 2) = " "
.Offset(iRow, iColumn + 3) = " "
.Offset(iRow, iColumn + 4) = "O"
.Offset(iRow, iColumn + 5) = _
" " & obj.Formula
.Offset(iRow, iColumn + 6) = _
" " & obj.Value
iRow = iRow + 1
End With
If iRow = 65536 Then
iColumn = iColumn + 8
iRow = 1
End If
End If
End If
' check drawing object name
If bTrueFalse = False Then
If InStr(obj.Name, varLookFor) 0 Then
With objOutputArea
'check to see if a match exists
'put information into
' strResultsTableName Worksheet
.Offset(iRow, iColumn) = " " & _
ActiveSheet.Name
.Offset(iRow, iColumn + 1) = _
TypeName(obj)
.Offset(iRow, iColumn + 2) = " "
.Offset(iRow, iColumn + 3) = " "
.Offset(iRow, iColumn + 4) = "O"
.Offset(iRow, iColumn + 5) = _
" " & obj.Name
.Offset(iRow, iColumn + 6) = ""
iRow = iRow + 1
End With
If iRow = 65536 Then
iColumn = iColumn + 8
iRow = 1
End If
End If
End If
Case "OLEObject"
bTrueFalse = True
bTrueFalse1 = False ' OLEType not a link
If obj.OLEType = xlOLELink Then ' Linked Object
If Val(Application.Version) = 8 Then
' in Excel 8 we can check the source of the
' link
If InStr(obj.SourceName, _
varLookFor) 0 Then
bTrueFalse1 = True 'OLEType is a link
' With varLookFor
With objOutputArea
'check to see if a match exists
'put information into
' strResultsTableName Worksheet
.Offset(iRow, iColumn) = _
" " & ActiveSheet.Name
.Offset(iRow, iColumn + 1) = _
" " & obj.Name
.Offset(iRow, iColumn + 2) = " "
.Offset(iRow, iColumn + 3) = " "
.Offset(iRow, iColumn + 4) = "O"
.Offset(iRow, iColumn + 5) = _
" " & obj.SourceName
.Offset(iRow, iColumn + 6) = ""
iRow = iRow + 1
End With
If iRow = 65536 Then
iColumn = iColumn + 8
iRow = 1
End If
End If
End If
Else
' check name in Embedded Objects and Linked
' Objects if
' it was not checked in the above test
If bTrueFalse1 = False Then
If InStr(obj.Name, varLookFor) 0 Then
With objOutputArea
'check to see if a match exists
'put information into
' strResultsTableName Worksheet
.Offset(iRow, iColumn) = _
" " & ActiveSheet.Name
.Offset(iRow, iColumn + 1) = _
" In name of"
.Offset(iRow, iColumn + 2) = " "
.Offset(iRow, iColumn + 3) = " "
.Offset(iRow, iColumn + 4) = "O"
.Offset(iRow, iColumn + 5) = _
" " & obj.Name
.Offset(iRow, iColumn + 6) = ""
iRow = iRow + 1
End With
If iRow = 65536 Then
iColumn = iColumn + 8
iRow = 1
End If
End If
End If
End If
Case "DropDown", "ListBox"
bTrueFalse = True
bTrueFalse1 = False
If InStr(obj.LinkedCell, varLookFor) 0 Then
bTrueFalse1 = True
With objOutputArea
'check to see if a match exists
'put information into
' strResultsTableName Worksheet
.Offset(iRow, iColumn) = _
" " & ActiveSheet.Name
.Offset(iRow, iColumn + 1) = _
TypeName(obj)
.Offset(iRow, iColumn + 2) = " "
.Offset(iRow, iColumn + 3) = " "
.Offset(iRow, iColumn + 4) = "O"
.Offset(iRow, iColumn + 5) = _
"LinkedCell: " & obj.LinkedCell
.Offset(iRow, iColumn + 6) = _
" " & obj.Name
iRow = iRow + 1
End With
If iRow = 65536 Then
iColumn = iColumn + 8
iRow = 1
End If
End If
If bTrueFalse1 = False Then
If InStr(obj.Name, varLookFor) 0 Then
With objOutputArea
'check to see if a match exists
'put information into
' strResultsTableName Worksheet
.Offset(iRow, iColumn) = _
" " & ActiveSheet.Name
.Offset(iRow, iColumn + 1) = _
TypeName(obj)
.Offset(iRow, iColumn + 2) = " "
.Offset(iRow, iColumn + 3) = " "
.Offset(iRow, iColumn + 4) = "O"
.Offset(iRow, iColumn + 5) = _
" " & obj.Name
.Offset(iRow, iColumn + 6) = ""
iRow = iRow + 1
End With
If iRow = 65536 Then
iColumn = iColumn + 8
iRow = 1
End If
End If
End If
If InStr(obj.ListFillRange, varLookFor) 0 Then
With objOutputArea
'check to see if a match exists
'put information into
' strResultsTableName Worksheet
.Offset(iRow, iColumn) = _
" " & ActiveSheet.Name
.Offset(iRow, iColumn + 1) = _
TypeName(obj)
.Offset(iRow, iColumn + 2) = " "
.Offset(iRow, iColumn + 3) = " "
.Offset(iRow, iColumn + 4) = "O"
.Offset(iRow, iColumn + 5) = _
"ListFillRange: " & _
obj.ListFillRange
.Offset(iRow, iColumn + 6) = _
" " & obj.Name
iRow = iRow + 1
End With
If iRow = 65536 Then
iColumn = iColumn + 8
iRow = 1
End If
End If
Case Else
If bTrueFalse = False Then
If InStr(obj.Name, varLookFor) 0 Then
With objOutputArea
'check to see if a match exists
'put information into
' strResultsTableName Worksheet
.Offset(iRow, iColumn) = _
" " & ActiveSheet.Name
.Offset(iRow, iColumn + 1) = _
TypeName(obj)
.Offset(iRow, iColumn + 2) = " "
.Offset(iRow, iColumn + 3) = " "
.Offset(iRow, iColumn + 4) = "O"
.Offset(iRow, iColumn + 5) = _
" " & obj.Name
.Offset(iRow, iColumn + 6) = ""
iRow = iRow + 1
End With
If iRow = 65536 Then
iColumn = iColumn + 8
iRow = 1
End If
End If
End If
End Select
Next
End If
Next x

'evaluate all ranges in the workbook
For Each nName In ActiveWorkbook.Names
With objOutputArea
bTrueFalse1 = False
If InStr(UCase(nName.Name), varLookFor) < 0 Then
bTrueFalse1 = True
'put information into StrResultstablename worksheet
.Offset(iRow, iColumn) = " " & nName.Name
.Offset(iRow, iColumn + 1) = ""
.Offset(iRow, iColumn + 2) = " "
.Offset(iRow, iColumn + 3) = " "
.Offset(iRow, iColumn + 4) = "R"
.Offset(iRow, iColumn + 5) = " " & nName.RefersTo
.Offset(iRow, iColumn + 6) = " " & nName.Value
iRow = iRow + 1
End If
If Not bTrueFalse1 Then
If InStr(UCase(nName.RefersTo), varLookFor) < 0 Then
'put information into StrResultstablename worksheet
.Offset(iRow, iColumn) = " " & nName.Name
.Offset(iRow, iColumn + 1) = ""
.Offset(iRow, iColumn + 2) = " "
.Offset(iRow, iColumn + 3) = " "
.Offset(iRow, iColumn + 4) = "R"
.Offset(iRow, iColumn + 5) = " " & nName.RefersTo
.Offset(iRow, iColumn + 6) = " " & nName.Value
iRow = iRow + 1
End If
End If
End With
Next

'Release all variables from memory
Set objRangeWithTextAndValues = Nothing
Set varCellFormula = Nothing
Set varAnswer = Nothing
Set objOutputArea = Nothing
Set objCell = Nothing
Set objRangeWithTextAndValues = Nothing

'start formatting output
Application.StatusBar = strStatusBarMsg2
Columns("A:G").EntireColumn.AutoFit

'creating comment
With Range("E1")
.Select
.AddComment
.Comment.Shape.Select True
.Comment.Text Text:= _
"Note:" & vbLf & "(F)ormula" & vbLf & _
"(O)bject" & vbLf & _
"(R)ange" & vbLf & "(V)alue/Text" & vbLf & "(W)orksheet"
Selection.ShapeRange.ScaleHeight 1.74, msoFalse, _
msoScaleFromTopLeft
.Comment.Visible = False
End With

'continue formatting output
Columns("A:A").Select
If Selection.ColumnWidth 50 Then
Selection.ColumnWidth = 50
End If

Columns("F:F").Select
If Selection.ColumnWidth 50 Then
Selection.ColumnWidth = 50
End If

Columns("G:G").Select
If Selection.ColumnWidth 50 Then
Selection.ColumnWidth = 50
End If

Columns("A:A,F:G").Select
With Selection
.WrapText = True
End With

Rows("1:1").Select
With Selection
.HorizontalAlignment = xlCenter
.WrapText = True
End With
With Selection.Font
.Underline = xlUnderlineStyleSingleAccounting
End With
Range("A2").Select
ActiveWindow.FreezePanes = True
Columns("B:E").Select
With Selection
.HorizontalAlignment = xlCenter
End With
Range("F1").Select
With Selection
.HorizontalAlignment = xlLeft
End With
Range("A:G").Select
With Selection
.VerticalAlignment = xlTop
End With

Range("A1:A1").Select
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, _
Key2:=Range("D2") _
, Order2:=xlAscending, Key3:=Range("C2"), _
Order3:=xlAscending, HEADER:= _
xlGuess, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom

Rows("1:1").Select
Selection.Insert Shift:=xlDown
dblLastRow = ActiveSheet.Cells.SpecialCells(xlLastCell).Row

If dblLastRow + 100 <= 65000 Then
dblLastRow = dblLastRow + 100
End If

ActiveWorkbook.ActiveSheet.Range("A1").WrapText = False
' ActiveWorkbook.ActiveSheet.Range("A1").value = _
' dblLastRow & " hit(s) on Search Criteria: " & _
' varLookFor_Original
Application.ActiveSheet.Range("A1").Formula = _
"=SubTotal(3,A3:A" & _
dblLastRow & ") & " & Chr(34) & _
" hit(s) on Search Criteria: " & _
varLookFor_Original & Chr(34)


Selection.Font.Bold = True

Range("A2").Select

'formatting printing
If Len(Range("A3").Value) < 0 Then
With ActiveSheet.PageSetup
.PrintTitleRows = "$1:$2"
End With
With ActiveSheet.PageSetup
.LeftMargin = Application.InchesToPoints(0.75)
.RightMargin = Application.InchesToPoints(0.25)
.TopMargin = Application.InchesToPoints(0.5)
.BottomMargin = Application.InchesToPoints(0.5)
.HeaderMargin = Application.InchesToPoints(0.25)
.FooterMargin = Application.InchesToPoints(0.25)
.Orientation = xlLandscape
.Order = xlOverThenDown
.Zoom = 80
.LeftHeader = "&""Tms Rmn,Bold""&U&A"
.LeftFooter = "Printed: &D - &T"
.CenterFooter = "Page &P of &N"
.RightFooter = "&F-&A"
.PrintGridlines = True
End With
End If

ActiveWindow.Zoom = 75

're-hide previously hidden sheets
On Error Resume Next
y = UBound(aryHiddensheets)
For x = 1 To y
Worksheets(aryHiddensheets(x)).Visible = False
Next

Application.Dialogs(xlDialogWorkbookName).Show

'Error Handling routines - currently not used
Exit_Err_Handler1:
Application.StatusBar = False
Exit Sub

Err_Handler1:
MsgBox Err.Description & " - (Error # " & Err.Number & ")"
Resume Exit_Err_Handler1

End Sub

'/===============================================/
Private Function funcCol(strAddress As String) As String
Dim i As Integer

For i = 1 To Len(strAddress)
If Asc(Mid(strAddress, i, 1)) < 58 Then
funcCol = Left(strAddress, i - 1)
Exit Function
End If
Next i

End Function
'/===============================================/
Private Function funcRow(strAddress As String) As String
Dim i As Integer

For i = 1 To Len(strAddress)
If Asc(Mid(strAddress, i, 1)) < 58 Then
funcRow = Right(strAddress, Len(strAddress) - i + 1)
Exit Function
End If
Next i

End Function
'/===============================================/
Public Function ErrorType(varTest As Variant) As String
Dim strAnswer As String

Application.Volatile True

Select Case varTest
Case CVErr(xlErrDiv0) '2007
strAnswer = "#Div/0!"
Case CVErr(xlErrNA) '2042
strAnswer = "#N/A"
Case CVErr(xlErrName) '2029
strAnswer = "#Name?"
Case CVErr(xlErrNull) '2000
strAnswer = "#Null!"
Case CVErr(xlErrNum) '2036
strAnswer = "#Num!"
Case CVErr(xlErrRef) '2023
strAnswer = "#Ref!"
Case CVErr(xlErrValue) '2015
strAnswer = "#Value!"
Case Else
strAnswer = "UNKNOWN"
End Select

ErrorType = strAnswer

End Function
'/===============================================/