Search for #'s in range
I've also found that if you give 50 programmers the same job, you'll get back
58 different products depending on the programmer's style (some will give you
2 or 3 different products). :O
The one you're talking about came from a John Walkenbach example.
Be good.
Gary
"Bob Phillips" wrote:
Gary,
What a lot of code for a simple job :-)
You can simplify this
Worksheets.Add.Move _
After:=Worksheets(Worksheets.Count)
'Name the new worksheet and set up Titles
ActiveWorkbook.ActiveSheet.name = _
strResultsTableName
To
Worksheets.Add.(After:=Worksheets(Worksheets.Count )). _
Name = strResultsTableName
--
HTH
RP
(remove nothere from the email address if mailing direct)
"Gary Brown" wrote in message
...
Hope this helps. Watch out for lines that wrap.
Option Explicit
'================================================= ========
Public Sub SelectedValuesInWorkSheet()
On Error Resume Next
'Purpose of this VBA program is to list all selected numbers
'in a Worksheet
' For use with EXCEL 97 or higher
'
Dim iRow As Long, iColumn As Long, dblLastRow As Long
Dim iTextValuesCount As Long
Dim i As Integer, iErrorTest As Integer, y As Integer
Dim x As Integer, iWorksheets As Integer
Dim objOutputArea As Object, objCell As Object
Dim objRangeWithTextAndValues As Object
Dim rngAnswer As Range
Dim strAnswer As String, strSheetName As String
Dim strResultsTableName As String, _
strInputQuestion As String
Dim strCurrentSelection As String
Dim varLookFor As Variant, varErrorTest As Variant
strResultsTableName = "Values_Table"
strCurrentSelection = Selection.Address
Application.DisplayAlerts = False
Set rngAnswer = _
Application.InputBox(prompt:="Select Cells: ", _
Default:=strCurrentSelection, Type:=8)
Application.DisplayAlerts = True
If Len(rngAnswer.Address) = 0 Then
MsgBox "No Cells were selected." & vbLf & vbLf & _
"Process Aborted.....", _
vbExclamation + vbOKOnly, "WARNING....."
Exit Sub
Else
rngAnswer.Select
strAnswer = rngAnswer.Address
End If
strInputQuestion = _
"Note: Continuing will list ALL " & _
"Values in ALL selected Cells " & _
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?"
varLookFor = _
MsgBox(strInputQuestion, _
vbExclamation + vbYesNo + vbDefaultButton2)
If varLookFor = vbNo Then
Exit Sub
End If
'Count number of worksheets in workbook
iWorksheets = ActiveWorkbook.Sheets.Count
'Check for duplicate Worksheet name
i = ActiveWorkbook.Sheets.Count
For x = 1 To i
If Windows.Count = 0 Then Exit Sub
If UCase(Worksheets(x).name) = _
UCase(strResultsTableName) Then
Worksheets(x).Activate
If Err.Number = 9 Then
Exit For
End If
Application.DisplayAlerts = False
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True
Exit For
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("D1").value = _
"Results Found"
ActiveWorkbook.ActiveSheet.Range("E1").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
'Go through selected cells one at a time looking
' for values
'Initialize value count variables
iTextValuesCount = 0
'Identify the cells with formulas and values in them
Set objRangeWithTextAndValues = Nothing
'Establish cells with formulas and values in them
On Error Resume Next
Set objRangeWithTextAndValues = _
rngAnswer.SpecialCells(xlTextValues)
iTextValuesCount = objRangeWithTextAndValues.Count
'if there are text/values
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
If CellType(objCell) = "Number" Then
With objOutputArea
'check to see if a match exists
'put information into StrResultstablename
worksheet
strSheetName = objCell.Parent.name
.Offset(iRow, iColumn) = " " & strSheetName
.Offset(iRow, iColumn + 1) = _
objCell.AddressLocal(rowabsolute:=False, _
columnabsolute:=False)
.Hyperlinks.Add Anchor:=.Offset(iRow, iColumn +
1),
_
Address:="", SubAddress:=Chr(39) &
strSheetName
& _
Chr(39) & "!" &
objCell.AddressLocal(rowabsolute:=False, _
columnabsolute:=False)
'.Offset(iRow, iColumn + 2) = "V"
.Offset(iRow, iColumn + 3) = " " & objCell.Formula
.Offset(iRow, iColumn + 4) = " " & objCell.value
iRow = iRow + 1
End With
End If
If iRow = 65536 Then
iColumn = iColumn + 5
iRow = 1
End If
Next objCell
End If
'Release all variables from memory
Set varLookFor = Nothing
Set objOutputArea = Nothing
Set objCell = Nothing
Set rngAnswer = Nothing
'formatting output
Columns("A:E").Select
Columns("A:E").EntireColumn.AutoFit
Columns("D:D").Select
If Selection.ColumnWidth 125 Then
Selection.ColumnWidth = 125
End If
With Selection
.WrapText = True
End With
Columns("E:E").Select
If Selection.ColumnWidth 50 Then
Selection.ColumnWidth = 50
End If
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:C").Select
With Selection
.HorizontalAlignment = xlCenter
End With
Range("D1").Select
With Selection
.HorizontalAlignment = xlLeft
End With
Range("A:E").Select
Range("E1").Activate
With Selection
.VerticalAlignment = xlTop
End With
Range("A1:A1").Select
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending,
Key2:=Range("B2")
_
, 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 & " value(s) in selected range: " & strSheetName &
_
' "![" & strAnswer & "]"
Application.ActiveSheet.Range("A1").Formula = "=SUBTOTAL(3,A3:A" & _
dblLastRow & ") & " & Chr(34) & " value(s) in selected range: " &
_
strSheetName & "![" & strAnswer & "]" & Chr(34)
Selection.Font.Bold = True
MsgBox rngAnswer.Address
Columns("C:C").Select
Selection.Delete Shift:=xlToLeft
Range("A2").Select
'formatting printing
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
ActiveWindow.Zoom = 75
'Error Handling routines - currently not used
Exit_Err_Handler1:
Application.Dialogs(xlDialogWorkbookName).Show
Exit Sub
Err_Handler1:
MsgBox Err.Description & " - (Error # " & Err.Number & ")"
Resume Exit_Err_Handler1
End Sub
'================================================= ========
Private Function CellType(rngCell As Range)
'There is no 'TypeName' worksheet function, only a VBA function.
'This program creates that 'worksheet' function
'
Dim strType As String
Application.Volatile
On Error GoTo err_Function
strType = ""
Select Case varType(rngCell)
Case vbInteger, vbLong, vbSingle, vbDouble, vbCurrency, vbDecimal,
vbByte
strType = "Number"
Case vbString
strType = "Text"
Case vbBoolean
strType = "Logical"
Case vbError
strType = "Error"
Case vbArray
strType = "Array"
Case vbEmpty, vbNull
strType = "Blank"
Case vbDate
strType = "Date"
Case vbObject, vbVariant, vbDataObject, vbUserDefinedType
strType = "Other"
Case Else
strType = "Unknown"
End Select
exit_Function:
CellType = strType
Exit Function
err_Function:
strType = ""
GoTo exit_Function
End Function
'/=========================================
"kinga" wrote in message
...
Hi,
Need some help writing some code to search a sheet's used cells for #'s,
save the cell reference and sheet name to an array and when its done,
list
the array items into a blank workbook or a text file.
If anyone can help me with some snippets of code, it would be much
appreciated.
Thanks
Mike
|