Stop the macro at the end of a certain column #2

  • Thread starter Carrie_Loos via OfficeKB.com
  • Start date
C

Carrie_Loos via OfficeKB.com

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
 
D

Dave Peterson

C.address is in A1 reference style.

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



Carrie_Loos via OfficeKB.com said:
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
Click to expand...
 
I

INTP56

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 said:
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
Click to expand...
 
J

JLGWhiz

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 said:
Same problem skip right to End If

Dave said:
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"
Click to expand...
[quoted text clipped - 52 lines]
Message posted via OfficeKB.com
http://www.officekb.com/Uwe/Forums.aspx/excel-programming/200801/1
Click to expand...
Click to expand...
Click to expand...
 
C

Carrie_Loos via 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"
Click to expand...
statement doesn't work. It does not recognize the cell address and this is
driving me crazy. Can you explain this?
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"
Click to expand...
[quoted text clipped - 48 lines]
End Sub
Click to expand...
Click to expand...
 
C

Carrie_Loos via OfficeKB.com

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)

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
Click to expand...
[quoted text clipped - 8 lines]
Click to expand...
 
J

JLGWhiz

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 said:
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)

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
Click to expand...
[quoted text clipped - 8 lines]
Message posted via OfficeKB.com
http://www.officekb.com/Uwe/Forums.aspx/excel-programming/200801/1
Click to expand...
Click to expand...
Click to expand...
 
C

Carrie_Loos via OfficeKB.com

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
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
Click to expand...
[quoted text clipped - 17 lines]
Click to expand...
 
D

Dave Peterson

c.address will have $'s in it.

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 said:
Same problem skip right to End If

Dave said:
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.aspx/excel-programming/200801/1
Click to expand...
Click to expand...
Click to expand...
 
D

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 said:
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
Click to expand...
 
C

Carrie_Loos via OfficeKB.com

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 said:
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"
Click to expand...
[quoted text clipped - 52 lines]
Message posted via OfficeKB.com
http://www.officekb.com/Uwe/Forums.aspx/excel-programming/200801/1
Click to expand...
Click to expand...
 
D

Dave Peterson

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 said:
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 said:
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"
Click to expand...
[quoted text clipped - 52 lines]
Message posted via OfficeKB.com
http://www.officekb.com/Uwe/Forums.aspx/excel-programming/200801/1
Click to expand...
Click to expand...
Click to expand...
 
C

Carrie_Loos via OfficeKB.com

Thank you, Thank you, Thank you!

Carrie

Dave said:
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
Click to expand...
[quoted text clipped - 183 lines]
Message posted via OfficeKB.com
http://www.officekb.com/Uwe/Forums.aspx/excel-programming/200802/1
Click to expand...
Click to expand...
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Stop the macro at the end of a certain column 3
Can't get the macro to continue through a range 2
Performing a Macro within a range 2
conso macro 0
If Cells.Find returns run-time error '91': Object variableor With block variable not set 1
Data Cleanse Macro Running Very Slow 0
Stop a find after the last occrance of the search value. 9
Find Question 1

Top