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

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

Thanks Gary,

Made me realise its probably easier to use a range and populate that with
the data using the offset code you had.

Cheers
Mike

"Gary Brown" wrote:

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

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

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

I agree. I find that 95% of my code is usually error-checking and
hand-holding for clients who will otherwise find 5 different ways of goofing
things up. I had this macro canned so I just adjusted it a little and sent
it through.
:O Have a good one.
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

"Gary Brown" wrote in message
...
I agree. I find that 95% of my code is usually error-checking and
hand-holding for clients who will otherwise find 5 different ways of
goofing
things up. I had this macro canned so I just adjusted it a little and
sent
it through.

I got that from the code, tons of checking and double-checking for the poo
souls that we support who have too much too do, too little time to do it,
and want to get it over with. I also got the impression that there was a lot
of stuff dusted off from the shelf :-)

My main point was to tell you something that you might not have known that I
think is a useful technique :-)

:O Have a good one.

And have one yourself.

You're Right! It was a dusty critter :O.
Thanks and appreciate your time.
Gary


"Bob Phillips" wrote:


"Gary Brown" wrote in message
...
I agree. I find that 95% of my code is usually error-checking and
hand-holding for clients who will otherwise find 5 different ways of
goofing
things up. I had this macro canned so I just adjusted it a little and
sent
it through.

I got that from the code, tons of checking and double-checking for the poo
souls that we support who have too much too do, too little time to do it,
and want to get it over with. I also got the impression that there was a lot
of stuff dusted off from the shelf :-)

My main point was to tell you something that you might not have known that I
think is a useful technique :-)

:O Have a good one.

And have one yourself.

Mike,

Here's a shorter version

Sub LoadCells()
Const wsData As String = "Display Data"
Dim sh As Worksheet
Dim rng As Range
Dim oCell As Range
Dim iRow As Long
Dim sStart As String
Dim ary

ReDim ary(1, 0)

For Each sh In ActiveWorkbook.Worksheets

If sh.name < wsData Then

Set rng = sh.UsedRange

Set oCell = Nothing
Set oCell = rng.Find("#")
If oCell Is Nothing Then
MsgBox "No matches found on " & sh.name
Else
With sh
ReDim Preserve ary(1, iRow)
ary(0, iRow) = rng.Parent.name
ary(1, iRow) = oCell.Address(False, False)
iRow = iRow + 1
sStart = oCell.Address

Do
Set oCell = rng.FindNext(oCell)
If Not oCell Is Nothing And oCell.Address < sStart
Then
ReDim Preserve ary(1, iRow)
ary(0, iRow) = rng.Parent.name
ary(1, iRow) = oCell.Address(False, False)
iRow = iRow + 1
End If
Loop While Not oCell Is Nothing And oCell.Address <
sStart
End With

End If 'sh.Name < wsData

End If 'If not sh.Name

Next sh

If Not SheetExists(wsData) Then
Worksheets.Add(after:=Worksheets(Worksheets.Count) ). _
name = wsData
Else
Worksheets(wsData).Cells.ClearContents
End If

For iRow = LBound(ary, 2) To UBound(ary, 2)
Worksheets(wsData).Cells(iRow + 1, "A") = ary(0, iRow)
Worksheets(wsData).Cells(iRow + 1, "B") = ary(1, iRow)
Next iRow


End Sub

'-----------------------------------------------------------------
Function SheetExists(sh As String, _
Optional wb As Workbook) As Boolean
'-----------------------------------------------------------------
Dim oWs As Worksheet
If wb Is Nothing Then Set wb = ActiveWorkbook
On Error Resume Next
SheetExists = CBool(Not wb.Worksheets(sh) Is Nothing)
On Error GoTo 0
End Function



--

HTH

RP
(remove nothere from the email address if mailing direct)


"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

Thanks Bob,

Nice, short and sweet. Thanks for your help.
Cheers
Mike

"Bob Phillips" wrote:

Mike,

Here's a shorter version

Sub LoadCells()
Const wsData As String = "Display Data"
Dim sh As Worksheet
Dim rng As Range
Dim oCell As Range
Dim iRow As Long
Dim sStart As String
Dim ary

ReDim ary(1, 0)

For Each sh In ActiveWorkbook.Worksheets

If sh.name < wsData Then

Set rng = sh.UsedRange

Set oCell = Nothing
Set oCell = rng.Find("#")
If oCell Is Nothing Then
MsgBox "No matches found on " & sh.name
Else
With sh
ReDim Preserve ary(1, iRow)
ary(0, iRow) = rng.Parent.name
ary(1, iRow) = oCell.Address(False, False)
iRow = iRow + 1
sStart = oCell.Address

Do
Set oCell = rng.FindNext(oCell)
If Not oCell Is Nothing And oCell.Address < sStart
Then
ReDim Preserve ary(1, iRow)
ary(0, iRow) = rng.Parent.name
ary(1, iRow) = oCell.Address(False, False)
iRow = iRow + 1
End If
Loop While Not oCell Is Nothing And oCell.Address <
sStart
End With

End If 'sh.Name < wsData

End If 'If not sh.Name

Next sh

If Not SheetExists(wsData) Then
Worksheets.Add(after:=Worksheets(Worksheets.Count) ). _
name = wsData
Else
Worksheets(wsData).Cells.ClearContents
End If

For iRow = LBound(ary, 2) To UBound(ary, 2)
Worksheets(wsData).Cells(iRow + 1, "A") = ary(0, iRow)
Worksheets(wsData).Cells(iRow + 1, "B") = ary(1, iRow)
Next iRow


End Sub

'-----------------------------------------------------------------
Function SheetExists(sh As String, _
Optional wb As Workbook) As Boolean
'-----------------------------------------------------------------
Dim oWs As Worksheet
If wb Is Nothing Then Set wb = ActiveWorkbook
On Error Resume Next
SheetExists = CBool(Not wb.Worksheets(sh) Is Nothing)
On Error GoTo 0
End Function



--

HTH

RP
(remove nothere from the email address if mailing direct)


"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