Does this help? Maybe if not directly, you can get some ideas.

Option Explicit

Sub FindOnes()
Dim r As Range, c As Range
Dim Topcell As Variant
Dim Bottomcell As Variant

Set r = ActiveSheet.Range("E3:AU65534")

Range("E3").Select

For Each c In r
'I don't understand why you go through every cell in the range
'Then look at all cells to find 1 and 2
Cells.Find( _
What:="1", _
After:=ActiveCell, _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=True _
).Activate
If ActiveCell.Value = 1 Then
Set Topcell = ActiveCell
If c.Address(ReferenceStyle:=xlR1C1) = "R65534C47" Then
Exit For
End If

Cells.Find( _
What:="2", _
After:=ActiveCell, _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=True _
).Activate

If ActiveCell.Value = 2 Then
Set Bottomcell = ActiveCell
If Topcell = 1 Then
Set Topcell = Topcell
End If
Range(Topcell, Bottomcell).Select
Selection.FillDown
Bottomcell.Select
End If
End If
Next

End Sub

Public Sub Findem()
With ActiveSheet
.Cells.Clear
.Cells(5, 4).Value = 1
.Cells(8, 4).Value = 2
.Cells(3, 5).Value = 1
.Cells(8, 5).Value = 2
.Cells(2, 6).Value = 1
.Cells(6, 6).Value = 2
.Cells(10, 7).Value = 1
.Cells(15, 7).Value = 2
End With
If 1 = 0 Then
FindOnesV2 wsCurrent:=ActiveSheet
Else
FindOnes
End If
End Sub

Private Sub FindOnesV2(wsCurrent As Worksheet)
Dim rngSearch As Range
Dim rngTop As Range
Dim rngBottom As Range
Dim rngFirst As Range

On Error GoTo ExitRoutine

If wsCurrent Is Nothing Then
GoTo ExitRoutine 'Or something more appropriate
End If

Set rngSearch = wsCurrent.Range( _
wsCurrent.Cells(3, 5), _
wsCurrent.Cells.SpecialCells(xlCellTypeLastCell))

Set rngFirst = rngSearch.Find( _
What:="1", _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=True)

Set rngTop = rngFirst
Do
Set rngBottom = rngSearch.Find( _
What:="2", _
After:=rngTop, _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=True)

If Not (rngBottom Is Nothing) Then
wsCurrent.Range(rngTop, rngBottom).Select
wsCurrent.Range(rngTop, rngBottom).FillDown
End If

Set rngTop = rngSearch.Find( _
What:="1", _
After:=rngBottom, _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=True)

Loop While (rngTop.Address < rngFirst.Address)

ExitRoutine:
If Err.Number < 0 Then
MsgBox CStr(Err.Number) & vbTab & Err.Description
End If
End Sub


Bob

"Carrie_Loos via OfficeKB.com" wrote:

Some nice person out there gave me the code " If c.Address = "R65535C47" Then
Exit For End If"
to end my macro but I just can't seem to get it to work. When I test the
macro everything runs fine, the highlight ends up at location R65535C47.
[This cell has a 1 in it] But it doesn't recognize the cell reference and
skips to the End IF. I have tried several different approaches but nothing
seems to work......Any Ideas?

(The macro is for class dates, it designates 1's for start dates and 2's for
end class dates then loops through an entire worksheet finds 1's and 2's and
fills in the cells inbetween with 1's)


Sub FindOnes()

Dim r As Range
Dim Topcell As Variant
Dim Bottomcell As Variant

Set r = ActiveSheet.Range("E3:AU65534")
Range("E3").Select

For Each c In r

Cells.Find(What:="1", After:=ActiveCell, LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:
= _
False, SearchFormat:=True).Activate
If ActiveCell.Value = 1 Then
Set Topcell = ActiveCell

If c.Address = "R65535C47" Then
Exit For
End If

Cells.Find(What:="2", After:=ActiveCell, LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:
= _
False, SearchFormat:=True).Activate
If ActiveCell.Value = 2 Then
Set Bottomcell = ActiveCell

If Topcell = 1 Then Set Topcell = Topcell
Range(Topcell, Bottomcell).Select
Selection.FillDown
Bottomcell.Select

End If
End If

Next

End Sub

--
Message posted via OfficeKB.com
http://www.officekb.com/Uwe/Forums.a...mming/200801/1