VBA to Fill all empty cells in all columns in a range

[Dennis]

What is the VBA code to:

1) calculate then select the complete "used range" (all rows & columns) in a
Worksheet
2) fill-down all empty cells with the last value preceding the empty cell, without
overwriting the data already there.


Original After Fill

1 11111 11111
2 22222 22222
3 22222
4 22222
5 12345 12345
6 67789 67789
7 78678 78678
8 78678
9 99999 99999

Using Excel 2003

TIA Dennis

ps. I have a separate question next post for an entirely different subject

 

[Debra Dalgleish]

There's a code sample here, for fill blank cells in a column:

http://www.contextures.com/xlDataEntry02.html

 

[Ken Wright]

So what happens if you don't have values in every cell of the top row of your
usedrange, as you will get 0s and references to cells at the bottom of the
sheet. If that is not an issue however, then try this:-

Sub FillBlanks()

Dim LCol As Long
Dim ColNum As Long
Dim Rng As Range
Dim Cel As Range

Application.ScreenUpdating = False

LCol = ActiveSheet.UsedRange.Column - 1 + _
ActiveSheet.UsedRange.Columns.Count

For ColNum = 1 To LCol
On Error Resume Next
Set Rng = Intersect(ActiveSheet.UsedRange, Columns(ColNum), _
Cells.SpecialCells(xlCellTypeBlanks))
For Each Cel In Rng
Cel.FormulaR1C1 = "=R[-1]C"
Next Cel
Next ColNum
Application.ScreenUpdating = True

End Sub


This leaves the formulas in there though. If you want the data hardcoded, then
amend to:-

Sub FillBlanks()

Dim LCol As Long
Dim ColNum As Long
Dim Rng As Range
Dim Cel As Range

Application.ScreenUpdating = False

LCol = ActiveSheet.UsedRange.Column - 1 + _
ActiveSheet.UsedRange.Columns.Count

For ColNum = 1 To LCol
On Error Resume Next
Set Rng = Intersect(ActiveSheet.UsedRange, Columns(ColNum), _
Cells.SpecialCells(xlCellTypeBlanks))
For Each Cel In Rng
Cel.FormulaR1C1 = "=R[-1]C"
Next Cel

With Columns(ColNum)
.Copy
.PasteSpecial Paste:=xlValues
End With

Next ColNum
Range("A1").Select
Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub


If you only want this done for cells between the first and last entry in each
column, then try this:-

Sub FillBlanks()

Dim LCol As Long
Dim ColNum As Long
Dim Rng As Range
Dim Cel As Range

Application.ScreenUpdating = False

LCol = ActiveSheet.UsedRange.Column - 1 + _
ActiveSheet.UsedRange.Columns.Count

For ColNum = 1 To LCol
On Error Resume Next
FrstRow = ActiveSheet.Cells(1, ColNum).End(xlDown).Row
LastRow = ActiveSheet.Cells(Rows.Count, ColNum).End(xlUp).Row
Set ColRng = Range(Cells(FrstRow, ColNum), Cells(LastRow, ColNum))

Set Rng = Intersect(ColRng, Columns(ColNum), _
Cells.SpecialCells(xlCellTypeBlanks))
For Each Cel In Rng
Cel.FormulaR1C1 = "=R[-1]C"
Next Cel

With Columns(ColNum)
.Copy
.PasteSpecial Paste:=xlValues
End With

Next ColNum
Range("A1").Select
Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub

 

[Dennis]

Thanks Debra & Ken for your knowledge & time! Dennis

 

[Alan Beban]

Sub test3001()
Dim rng As Range, iCell As Range
Set rng = _
Worksheets("Sheet4").UsedRange.SpecialCells(xlCellTypeBlanks)
For Each iCell In rng
iCell.Value = iCell.Offset(-1, 0).Value
Next
End Sub

Alan Beban