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

C.address is in A1 reference style.

You could check
if c.address = "$AU$65535"



"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

--

Dave Peterson

Same problem skip right to End If

Dave Peterson wrote:
C.address is in A1 reference style.

You could check
if c.address = "$AU$65535"

Some nice person out there gave me the code " If c.Address = "R65535C47" Then
Exit For End If"
[quoted text clipped - 52 lines]
Message posted via OfficeKB.com
http://www.officekb.com/Uwe/Forums.a...mming/200801/1


--
Message posted via http://www.officekb.com

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

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

If you want c to reach AU65535 then you will have to change the range for r.
See above. You can either change that range to E3:AU65535 or change the If
statement to: If c.Address = "AU65534" Then




"Carrie_Loos via OfficeKB.com" wrote:

Same problem skip right to End If

Dave Peterson wrote:
C.address is in A1 reference style.

You could check
if c.address = "$AU$65535"

Some nice person out there gave me the code " If c.Address = "R65535C47" Then
Exit For End If"
[quoted text clipped - 52 lines]
Message posted via OfficeKB.com
http://www.officekb.com/Uwe/Forums.a...mming/200801/1


--
Message posted via http://www.officekb.com

Wow - Thank you - This is a lot to review and I am always excited to read and
interpret new ways to look at code as I am obviously not an expert in this
area.

To answer your question I never could get the macro stay within the range so
its and old line that can be deleted. Also I chose to use the Find to look at
every cell because it was the only way I could figure out how to datafill the
cells inbetween the 1's and 2's. After it is a converted into a string of 1's
it is indexed into another worsheet that calendars the time. Long story...it
works into several other worksheets and code so I don't really have a choice.

But I still do not understand why the "If c.Address(ReferenceStyle:=xlR1C1) =
"R65534C47" Then
Exit For
End If"
statement doesn't work. It does not recognize the cell address and this is
driving me crazy. Can you explain this?

INTP56 wrote:
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

Some nice person out there gave me the code " If c.Address = "R65535C47" Then
Exit For End If"
[quoted text clipped - 48 lines]

End Sub

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

Thanks and you are right I forgot to change the range back to AU65535.
However it still did not solve my problem. The statement does not recognize
that it is on that address and I just don't get it.

As well as:
It seems to be the "Find" portion that will not stay within the set range as
I have it written but I also have to find each occurance of the 1's and 2's
to do a datafill iinbetween them which doesn't work any other way that I have
found (excluding the previous answer which I have not disected yet)


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

If you want c to reach AU65535 then you will have to change the range for r.
See above. You can either change that range to E3:AU65535 or change the If
statement to: If c.Address = "AU65534" Then

Same problem skip right to End If

[quoted text clipped - 8 lines]
Message posted via OfficeKB.com
http://www.officekb.com/Uwe/Forums.a...mming/200801/1

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

It could be that you need a brief delay just after that statement to give the
Exit For
time to work. Try inserting this snippet in just after the if statement:

s = Timer + 0.5
Do While Timer < s
DoEvents
Loop

That will give it a half second delay. If it still don't exit, I have no
other guesses.


"Carrie_Loos via OfficeKB.com" wrote:

Thanks and you are right I forgot to change the range back to AU65535.
However it still did not solve my problem. The statement does not recognize
that it is on that address and I just don't get it.

As well as:
It seems to be the "Find" portion that will not stay within the set range as
I have it written but I also have to find each occurance of the 1's and 2's
to do a datafill iinbetween them which doesn't work any other way that I have
found (excluding the previous answer which I have not disected yet)


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

If you want c to reach AU65535 then you will have to change the range for r.
See above. You can either change that range to E3:AU65535 or change the If
statement to: If c.Address = "AU65534" Then

Same problem skip right to End If

[quoted text clipped - 8 lines]
Message posted via OfficeKB.com
http://www.officekb.com/Uwe/Forums.a...mming/200801/1

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

Well - the snippit is great - I was unaware of how to write a time event -
Love to learn new things - BU But still no luck with the If c.address
statement. I even removed the little portion of the code and tried it on a
blank worksheet without success. Is it possible 'Address' is not stored in my
library correctly? Anyway - I think I will take a fresh look at this
tommorrow. I sure appreciate all your suggestions.

Carrie

JLGWhiz wrote:
It could be that you need a brief delay just after that statement to give the
Exit For
time to work. Try inserting this snippet in just after the if statement:

s = Timer + 0.5
Do While Timer < s
DoEvents
Loop

That will give it a half second delay. If it still don't exit, I have no
other guesses.

Thanks and you are right I forgot to change the range back to AU65535.
However it still did not solve my problem. The statement does not recognize
[quoted text clipped - 17 lines]
Message posted via OfficeKB.com
http://www.officekb.com/Uwe/Forums.a...mming/200801/1

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

c.address will have $'s in it.


JLGWhiz wrote:

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

If you want c to reach AU65535 then you will have to change the range for r.
See above. You can either change that range to E3:AU65535 or change the If
statement to: If c.Address = "AU65534" Then

"Carrie_Loos via OfficeKB.com" wrote:

Same problem skip right to End If

Dave Peterson wrote:
C.address is in A1 reference style.

You could check
if c.address = "$AU$65535"

Some nice person out there gave me the code " If c.Address = "R65535C47" Then
Exit For End If"
[quoted text clipped - 52 lines]
Message posted via OfficeKB.com
http://www.officekb.com/Uwe/Forums.a...mming/200801/1


--
Message posted via http://www.officekb.com



--

Dave Peterson

I'm not sure I understand, but say you have 3 columns that look like:

1 - -
- - -
- 1 -
- - -
2 - -
- - -
- 2 -
- - -
1 - -
- - -
- 1 1
- - -
- - -
2 - -
- - 2
- 2 -
- - -
- - -
1 - 1
- - -
- 1 -
- - -
2 - -
- - 2
- 2 -
- - -
- - -
- - -
- - 1
- - -
- - -
- - -
- - 2

(the hyphen is an empty cell)

And you want it to look like this after you're done:

1 - -
1 - -
1 1 -
1 1 -
2 1 -
- 1 -
- 2 -
- - -
1 - -
1 - -
1 1 1
1 1 1
1 1 1
2 1 1
- 1 2
- 2 -
- - -
- - -
1 - 1
1 - 1
1 1 1
1 1 1
2 1 1
- 1 2
- 2 -
- - -
- - -
- - -
- - 1
- - 1
- - 1
- - 1
- - 2

Then this seemed to work ok for me--try it against a copy of your data--it
destroys the original by filling those cells with 1's.

Option Explicit
Sub Testme01()

Dim TopCell As Range
Dim BotCell As Range
Dim wks As Worksheet
Dim iCol As Long
Dim FirstCol As Long
Dim LastCol As Long
Dim RngToSearch As Range
Dim FirstAddress As String
Dim HowManyRowsToFill As Long

Set wks = Worksheets("sheet1")

With wks
FirstCol = .Range("e3").Column
LastCol = .Range("au3").Column
For iCol = FirstCol To LastCol
FirstAddress = ""
Set RngToSearch _
= .Range(.Cells(3, iCol), .Cells(.Rows.Count, iCol).End(xlUp))
With RngToSearch
Set TopCell = .Cells.Find(what:="1", _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, _
MatchCase:=False)
End With

If TopCell Is Nothing Then
'nothing to do in this column
MsgBox "no 1's in column: " & ColLetter(iCol)
Else
FirstAddress = TopCell.Address
Do
With RngToSearch
Set BotCell = .Cells.Find(what:="2", _
After:=TopCell, _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, _
MatchCase:=False)
End With

If BotCell.Row < TopCell.Row Then
MsgBox "No trailing 2 for last 1 in column: " _
& ColLetter(iCol)
Exit Do
End If

If BotCell Is Nothing Then
MsgBox "No corresponding 2's in column: " _
& ColLetter(iCol)
Exit Do
End If

HowManyRowsToFill = BotCell.Row - TopCell.Row - 1
If HowManyRowsToFill 0 Then
TopCell.Offset(1, 0) _
.Resize(HowManyRowsToFill, 1).Value = 1
End If

'try to find the next 1
With RngToSearch
Set TopCell = .Cells.Find(what:="1", _
After:=BotCell, _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, _
MatchCase:=False)
End With

If TopCell.Address = FirstAddress Then
'at the top of the column again
'get out and do the next column
Exit Do
End If
Loop
End If
Next iCol
End With
End Sub
Function ColLetter(myNum As Long) As String
Dim myStr As String
myStr = Worksheets(1).Cells(1, myNum).Address(0, 0)
myStr = Left(myStr, Len(myStr) - 1)
ColLetter = myStr
End Function



"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

--

Dave Peterson

This is awsome! Wow! - It does exactly what I want! Thank you so much

But I do have an error not sure how to handle it, its stopping on the line
"If BotCell.Row < TopCell.Row Then" with Run Time Error 91 - object variable
or block variable not set - I don't see a missing variable? (Just a after
thought, the blank cells are actually zero's - Does it matter?)

Dave Peterson wrote:
I'm not sure I understand, but say you have 3 columns that look like:

1 - -
- - -
- 1 -
- - -
2 - -
- - -
- 2 -
- - -
1 - -
- - -
- 1 1
- - -
- - -
2 - -
- - 2
- 2 -
- - -
- - -
1 - 1
- - -
- 1 -
- - -
2 - -
- - 2
- 2 -
- - -
- - -
- - -
- - 1
- - -
- - -
- - -
- - 2

(the hyphen is an empty cell)

And you want it to look like this after you're done:

1 - -
1 - -
1 1 -
1 1 -
2 1 -
- 1 -
- 2 -
- - -
1 - -
1 - -
1 1 1
1 1 1
1 1 1
2 1 1
- 1 2
- 2 -
- - -
- - -
1 - 1
1 - 1
1 1 1
1 1 1
2 1 1
- 1 2
- 2 -
- - -
- - -
- - -
- - 1
- - 1
- - 1
- - 1
- - 2

Then this seemed to work ok for me--try it against a copy of your data--it
destroys the original by filling those cells with 1's.

Option Explicit
Sub Testme01()

Dim TopCell As Range
Dim BotCell As Range
Dim wks As Worksheet
Dim iCol As Long
Dim FirstCol As Long
Dim LastCol As Long
Dim RngToSearch As Range
Dim FirstAddress As String
Dim HowManyRowsToFill As Long

Set wks = Worksheets("sheet1")

With wks
FirstCol = .Range("e3").Column
LastCol = .Range("au3").Column
For iCol = FirstCol To LastCol
FirstAddress = ""
Set RngToSearch _
= .Range(.Cells(3, iCol), .Cells(.Rows.Count, iCol).End(xlUp))
With RngToSearch
Set TopCell = .Cells.Find(what:="1", _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, _
MatchCase:=False)
End With

If TopCell Is Nothing Then
'nothing to do in this column
MsgBox "no 1's in column: " & ColLetter(iCol)
Else
FirstAddress = TopCell.Address
Do
With RngToSearch
Set BotCell = .Cells.Find(what:="2", _
After:=TopCell, _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, _
MatchCase:=False)
End With

If BotCell.Row < TopCell.Row Then
MsgBox "No trailing 2 for last 1 in column: " _
& ColLetter(iCol)
Exit Do
End If

If BotCell Is Nothing Then
MsgBox "No corresponding 2's in column: " _
& ColLetter(iCol)
Exit Do
End If

HowManyRowsToFill = BotCell.Row - TopCell.Row - 1
If HowManyRowsToFill 0 Then
TopCell.Offset(1, 0) _
.Resize(HowManyRowsToFill, 1).Value = 1
End If

'try to find the next 1
With RngToSearch
Set TopCell = .Cells.Find(what:="1", _
After:=BotCell, _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, _
MatchCase:=False)
End With

If TopCell.Address = FirstAddress Then
'at the top of the column again
'get out and do the next column
Exit Do
End If
Loop
End If
Next iCol
End With
End Sub
Function ColLetter(myNum As Long) As String
Dim myStr As String
myStr = Worksheets(1).Cells(1, myNum).Address(0, 0)
myStr = Left(myStr, Len(myStr) - 1)
ColLetter = myStr
End Function

Some nice person out there gave me the code " If c.Address = "R65535C47" Then
Exit For End If"
[quoted text clipped - 52 lines]
Message posted via OfficeKB.com
http://www.officekb.com/Uwe/Forums.a...mming/200801/1


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

Oops. I added some code at the end and I put it in the wrong spot.

Option Explicit
Sub Testme01()

Dim TopCell As Range
Dim BotCell As Range
Dim wks As Worksheet
Dim iCol As Long
Dim FirstCol As Long
Dim LastCol As Long
Dim RngToSearch As Range
Dim FirstAddress As String
Dim HowManyRowsToFill As Long

Set wks = Worksheets("sheet1")

With wks
FirstCol = .Range("e3").Column
LastCol = .Range("au3").Column
For iCol = FirstCol To LastCol
FirstAddress = ""
Set RngToSearch _
= .Range(.Cells(3, iCol), .Cells(.Rows.Count, iCol).End(xlUp))
With RngToSearch
Set TopCell = .Cells.Find(what:="1", _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, _
MatchCase:=False)
End With

If TopCell Is Nothing Then
'nothing to do in this column
MsgBox "no 1's in column: " & ColLetter(iCol)
Else
FirstAddress = TopCell.Address
Do
With RngToSearch
Set BotCell = .Cells.Find(what:="2", _
After:=TopCell, _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, _
MatchCase:=False)
End With

'check for nothing first!
If BotCell Is Nothing Then
MsgBox "No corresponding 2's in column: " _
& ColLetter(iCol)
Exit Do
End If

If BotCell.Row < TopCell.Row Then
MsgBox "No trailing 2 for last 1 in column: " _
& ColLetter(iCol)
Exit Do
End If

HowManyRowsToFill = BotCell.Row - TopCell.Row - 1
If HowManyRowsToFill 0 Then
TopCell.Offset(1, 0) _
.Resize(HowManyRowsToFill, 1).Value = 1
End If

'try to find the next 1
With RngToSearch
Set TopCell = .Cells.Find(what:="1", _
After:=BotCell, _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, _
MatchCase:=False)
End With

If TopCell.Address = FirstAddress Then
'at the top of the column again
'get out and do the next column
Exit Do
End If
Loop
End If
Next iCol
End With
End Sub
Function ColLetter(myNum As Long) As String
Dim myStr As String
myStr = Worksheets(1).Cells(1, myNum).Address(0, 0)
myStr = Left(myStr, Len(myStr) - 1)
ColLetter = myStr
End Function

"Carrie_Loos via OfficeKB.com" wrote:

This is awsome! Wow! - It does exactly what I want! Thank you so much

But I do have an error not sure how to handle it, its stopping on the line
"If BotCell.Row < TopCell.Row Then" with Run Time Error 91 - object variable
or block variable not set - I don't see a missing variable? (Just a after
thought, the blank cells are actually zero's - Does it matter?)

Dave Peterson wrote:
I'm not sure I understand, but say you have 3 columns that look like:

1 - -
- - -
- 1 -
- - -
2 - -
- - -
- 2 -
- - -
1 - -
- - -
- 1 1
- - -
- - -
2 - -
- - 2
- 2 -
- - -
- - -
1 - 1
- - -
- 1 -
- - -
2 - -
- - 2
- 2 -
- - -
- - -
- - -
- - 1
- - -
- - -
- - -
- - 2

(the hyphen is an empty cell)

And you want it to look like this after you're done:

1 - -
1 - -
1 1 -
1 1 -
2 1 -
- 1 -
- 2 -
- - -
1 - -
1 - -
1 1 1
1 1 1
1 1 1
2 1 1
- 1 2
- 2 -
- - -
- - -
1 - 1
1 - 1
1 1 1
1 1 1
2 1 1
- 1 2
- 2 -
- - -
- - -
- - -
- - 1
- - 1
- - 1
- - 1
- - 2

Then this seemed to work ok for me--try it against a copy of your data--it
destroys the original by filling those cells with 1's.

Option Explicit
Sub Testme01()

Dim TopCell As Range
Dim BotCell As Range
Dim wks As Worksheet
Dim iCol As Long
Dim FirstCol As Long
Dim LastCol As Long
Dim RngToSearch As Range
Dim FirstAddress As String
Dim HowManyRowsToFill As Long

Set wks = Worksheets("sheet1")

With wks
FirstCol = .Range("e3").Column
LastCol = .Range("au3").Column
For iCol = FirstCol To LastCol
FirstAddress = ""
Set RngToSearch _
= .Range(.Cells(3, iCol), .Cells(.Rows.Count, iCol).End(xlUp))
With RngToSearch
Set TopCell = .Cells.Find(what:="1", _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, _
MatchCase:=False)
End With

If TopCell Is Nothing Then
'nothing to do in this column
MsgBox "no 1's in column: " & ColLetter(iCol)
Else
FirstAddress = TopCell.Address
Do
With RngToSearch
Set BotCell = .Cells.Find(what:="2", _
After:=TopCell, _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, _
MatchCase:=False)
End With

If BotCell.Row < TopCell.Row Then
MsgBox "No trailing 2 for last 1 in column: " _
& ColLetter(iCol)
Exit Do
End If

If BotCell Is Nothing Then
MsgBox "No corresponding 2's in column: " _
& ColLetter(iCol)
Exit Do
End If

HowManyRowsToFill = BotCell.Row - TopCell.Row - 1
If HowManyRowsToFill 0 Then
TopCell.Offset(1, 0) _
.Resize(HowManyRowsToFill, 1).Value = 1
End If

'try to find the next 1
With RngToSearch
Set TopCell = .Cells.Find(what:="1", _
After:=BotCell, _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, _
MatchCase:=False)
End With

If TopCell.Address = FirstAddress Then
'at the top of the column again
'get out and do the next column
Exit Do
End If
Loop
End If
Next iCol
End With
End Sub
Function ColLetter(myNum As Long) As String
Dim myStr As String
myStr = Worksheets(1).Cells(1, myNum).Address(0, 0)
myStr = Left(myStr, Len(myStr) - 1)
ColLetter = myStr
End Function

Some nice person out there gave me the code " If c.Address = "R65535C47" Then
Exit For End If"
[quoted text clipped - 52 lines]
Message posted via OfficeKB.com
http://www.officekb.com/Uwe/Forums.a...mming/200801/1


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

--

Dave Peterson

Thank you, Thank you, Thank you!

Carrie

Dave Peterson wrote:
Oops. I added some code at the end and I put it in the wrong spot.

Option Explicit
Sub Testme01()

Dim TopCell As Range
Dim BotCell As Range
Dim wks As Worksheet
Dim iCol As Long
Dim FirstCol As Long
Dim LastCol As Long
Dim RngToSearch As Range
Dim FirstAddress As String
Dim HowManyRowsToFill As Long

Set wks = Worksheets("sheet1")

With wks
FirstCol = .Range("e3").Column
LastCol = .Range("au3").Column
For iCol = FirstCol To LastCol
FirstAddress = ""
Set RngToSearch _
= .Range(.Cells(3, iCol), .Cells(.Rows.Count, iCol).End(xlUp))
With RngToSearch
Set TopCell = .Cells.Find(what:="1", _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, _
MatchCase:=False)
End With

If TopCell Is Nothing Then
'nothing to do in this column
MsgBox "no 1's in column: " & ColLetter(iCol)
Else
FirstAddress = TopCell.Address
Do
With RngToSearch
Set BotCell = .Cells.Find(what:="2", _
After:=TopCell, _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, _
MatchCase:=False)
End With

'check for nothing first!
If BotCell Is Nothing Then
MsgBox "No corresponding 2's in column: " _
& ColLetter(iCol)
Exit Do
End If

If BotCell.Row < TopCell.Row Then
MsgBox "No trailing 2 for last 1 in column: " _
& ColLetter(iCol)
Exit Do
End If

HowManyRowsToFill = BotCell.Row - TopCell.Row - 1
If HowManyRowsToFill 0 Then
TopCell.Offset(1, 0) _
.Resize(HowManyRowsToFill, 1).Value = 1
End If

'try to find the next 1
With RngToSearch
Set TopCell = .Cells.Find(what:="1", _
After:=BotCell, _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, _
MatchCase:=False)
End With

If TopCell.Address = FirstAddress Then
'at the top of the column again
'get out and do the next column
Exit Do
End If
Loop
End If
Next iCol
End With
End Sub
Function ColLetter(myNum As Long) As String
Dim myStr As String
myStr = Worksheets(1).Cells(1, myNum).Address(0, 0)
myStr = Left(myStr, Len(myStr) - 1)
ColLetter = myStr
End Function

This is awsome! Wow! - It does exactly what I want! Thank you so much

[quoted text clipped - 183 lines]
Message posted via OfficeKB.com
http://www.officekb.com/Uwe/Forums.a...mming/200802/1


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