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