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