Thread: Find Macro

I have a workbook with multiple sheets and thousands of entries. I would
like to search the workbook for entries that would be similar to this:

abcde-s-1234 or efghij-s-56789

The only common this is the -s- in the cells that would be 5 or 6 places
over from the left. I would like to locate all the -s entries and write them
to another sheet or workbook.

Thanks,
Jerry

Run 'SearchFinder'. It is an adaptation of something Mr. Manville wrote
about 7 years ago.

hth,
--
Gary Brown
gary_brown@ge_NOSPAM.com
If this post was helpful, please click the ''Yes'' button next to ''Was this
Post Helpfull to you?''.



When it asks you what you are looking for, put *-s-* as the searched for
criteria....


'==START OF MACRO TO BE COPIED ==========================
Option Compare Text
'Gary L. Brown
'Kinneson Consulting
'www.kinneson.com
'
'Version 1a: 01/2000 - ranges included in search
'Version 2.0: 03/21/2000 - names of sheets in workbook included in search
'Version 3.0: 04/20/2000 - DrawingObjects in workbook 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 appropriate 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, 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 x = 1 To i
For Each objSheet In ActiveWorkbook.Sheets
If Windows.Count = 0 Then Exit Sub
' If UCase(Worksheets(x).Name) = UCase(strResultsTableName) Then
If UCase(objSheet.name) = UCase(strResultsTableName) Then
' Worksheets(x).Activate
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 the 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 into 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
'====END OF MACRO TO BE COPIED =========================

"Gary L Brown" <gary_brown@ge_NOSPAM.com> wrote in message
news:F028C482-239C-435C-B0C2-0EC244308F1B@microsoft.com...
> Run 'SearchFinder'. It is an adaptation of something Mr. Manville wrote
> about 7 years ago.
>
> hth,
> --
> Gary Brown
> gary_brown@ge_NOSPAM.com
> If this post was helpful, please click the ''Yes'' button next to ''Was
> this
> Post Helpfull to you?''.
>
>
>
> When it asks you what you are looking for, put *-s-* as the searched for
> criteria....
>


That worked really very well.

Now I have 2 different worksheets 1 & 2 that will have some cell data that
is the same. I would like to compare the cell entries of both sheets for a
match. For every one of the entries not found in sheet 2 that are in sheet
1, I would like to write them to another sheet. For everything not found in
both sheets, write them to another.

Thanks.

Take a look at...
http://www.comparesuite.com/support/...readsheets.htm
HTH,
--
Gary Brown
gary_brown@ge_NOSPAM.com
If this post was helpful, please click the ''Yes'' button next to ''Was this
Post Helpfull to you?''.


"Jerry" wrote:

>
> "Gary L Brown" <gary_brown@ge_NOSPAM.com> wrote in message
> news:F028C482-239C-435C-B0C2-0EC244308F1B@microsoft.com...
> > Run 'SearchFinder'. It is an adaptation of something Mr. Manville wrote
> > about 7 years ago.
> >
> > hth,
> > --
> > Gary Brown
> > gary_brown@ge_NOSPAM.com
> > If this post was helpful, please click the ''Yes'' button next to ''Was
> > this
> > Post Helpfull to you?''.
> >
> >
> >
> > When it asks you what you are looking for, put *-s-* as the searched for
> > criteria....
> >
>
>
> That worked really very well.
>
> Now I have 2 different worksheets 1 & 2 that will have some cell data that
> is the same. I would like to compare the cell entries of both sheets for a
> match. For every one of the entries not found in sheet 2 that are in sheet
> 1, I would like to write them to another sheet. For everything not found in
> both sheets, write them to another.
>
> Thanks.
>
>
>

http://www.cpearson.com/excel/duplicat.htm

--
Regards,
Tom Ogilvy


"Jerry" <dancnman@houston.rr.com> wrote in message
news:N%Dxf.9996$SD1.1660@tornado.texas.rr.com...
>
> "Gary L Brown" <gary_brown@ge_NOSPAM.com> wrote in message
> news:F028C482-239C-435C-B0C2-0EC244308F1B@microsoft.com...
> > Run 'SearchFinder'. It is an adaptation of something Mr. Manville wrote
> > about 7 years ago.
> >
> > hth,
> > --
> > Gary Brown
> > gary_brown@ge_NOSPAM.com
> > If this post was helpful, please click the ''Yes'' button next to ''Was
> > this
> > Post Helpfull to you?''.
> >
> >
> >
> > When it asks you what you are looking for, put *-s-* as the searched for
> > criteria....
> >
>
>
> That worked really very well.
>
> Now I have 2 different worksheets 1 & 2 that will have some cell data that
> is the same. I would like to compare the cell entries of both sheets for a
> match. For every one of the entries not found in sheet 2 that are in sheet
> 1, I would like to write them to another sheet. For everything not found
in
> both sheets, write them to another.
>
> Thanks.
>
>

"Jerry" <dancnman@houston.rr.com> wrote in message
news:fCBxf.8997$SD1.4950@tornado.texas.rr.com...
> I have a workbook with multiple sheets and thousands of entries. I would
> like to search the workbook for entries that would be similar to this:
>
> abcde-s-1234 or efghij-s-56789
>
> The only common this is the -s- in the cells that would be 5 or 6 places
> over from the left. I would like to locate all the -s entries and write
> them to another sheet or workbook.
>
> Thanks,
> Jerry
>

Here is what I found that works well also. I would like for it or something
like it to open a new workbook and write what it finds to it.

Thanks,
Jerry

Sub SearchWorkbook()
Dim Wksh As Worksheet
Dim FindString As String
Dim Msgtext As String


Msgtext = "The string was found; do you want to continue searching?"
Prompt = "Enter the string to search for"
Title = "Find for All Sheets"

' Display the Input Box
On Error Resume Next

FindString = Application.InputBox(Prompt:=Prompt, _
Title:=Title, Type:=2) 'Text to find (string)

' Was the Input Box canceled?
If FindString = "" Then
MsgBox "Canceled."
End 'exit the macro
End If

'Search thru all sheets
For Each Wksh In ActiveWorkbook.Worksheets
With Wksh.UsedRange
Set c = .Find(FindString, LookIn:=xlValues, _
Lookat:=xlPart, MatchCase:=False)
If Not c Is Nothing Then
firstAddress = c.Address
Wksh.Activate
Do
'c.Interior.ColorIndex = 45
'c.Interior.Pattern = xlPatternGray50
'change color--if desired for found cell
c.Select


Reply = MsgBox(Msgtext, vbYesNo, Title)
If Reply = vbNo Then End
'MsgBox "Search Canceled"
'End If

'Exit the macro if No chosen

Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With
Next
End Sub

Can a function key on the keypad be converted to ":" entry.
I want to key in 2330 and have it entered as time 23:30 in excel

Thanks,
Ron
805-529-8300