How to generate a file copy of the Excel Find results list
Is it important to fix?
Option Explicit
Sub testme01()
Dim curWkbk As Workbook
Dim wks As Worksheet
Dim RptWks As Worksheet
Dim oRow As Long
Dim MaxRows As Long
Dim oCol As Long
Dim FoundCell As Range
Dim FirstAddress As String
Dim FindWhat As String
FindWhat = InputBox(Prompt:="Find What?")
If FindWhat = "" Then
Exit Sub
End If
Set curWkbk = ActiveWorkbook
Set RptWks = Workbooks.Add(1).Worksheets(1)
MaxRows = 40000
oRow = 99999
oCol = -3
For Each wks In curWkbk.Worksheets
With wks.Cells
Set FoundCell = .Find(what:=FindWhat, lookat:=xlPart, _
LookIn:=xlFormulas, _
after:=.Cells(.Cells.Count), _
searchdirection:=xlNext, MatchCase:=False)
If Not FoundCell Is Nothing Then
FirstAddress = FoundCell.Address
Do
If oRow MaxRows - 1 Then
If oCol 252 Then
Set RptWks = RptWks.Parent.Worksheets.Add
oCol = -3
End If
oCol = oCol + 4
RptWks.Cells(1, oCol).Resize(1, 4).Value _
= Array("Worksheet Name", "Address", _
"Value", "Formula")
oRow = 1
End If
oRow = oRow + 1
With RptWks.Cells(oRow, oCol)
.Value = "'" & FoundCell.Parent.Name
.Offset(0, 1).Value = FoundCell.Address
With .Offset(0, 2)
.Value = "'" & FoundCell.Text
End With
If FoundCell.HasFormula Then
.Offset(0, 3).Value = "'" & FoundCell.Formula
End If
End With
Set FoundCell = .FindNext(FoundCell)
Loop While Not FoundCell Is Nothing _
And FoundCell.Address < FirstAddress
End If
End With
Next wks
End Sub
This addresses the running out of rows problem (and running out of columns).
But I weaseled out on the '===== stuff.
When you put that ==== in a cell, excel sees it as the beginning of a formula.
And it's not a nice formula.
There are other things that can cause this trouble, too. Plus, minus (+/-) and
excel will think you're starting another formula. And if your value looks like
a date (12/15/05), excel will interpret it as a date. (same thing with time).
So instead of fiddling with it, I just chose to show the text of the cell--not
the value (and I put a single quote in front).
With .Offset(0, 2)
.Value = "'" & FoundCell.Text
End With
MrSpreadsheet wrote:
The testme macro ran as expected and produced results in exactly the
right order, thank you.
In testing there were two exceptions a) any cell containing a string
similar to '===== halted the macro and b) oRow greater than the max
allowed in Excel runs 'forever'.
--
Dave Peterson
|