Fill-Down Macro

[ethoros]

This Macro will fill down the selected cell to the last cell with a value in.

great for filling down formulas in list. it also only keeps the top most formula to reduce calculation times.


I have included the multi filldown so multiple columns can be executed.


Sub FillDown()

Dim oWS As Worksheet

Set oWS = ActiveSheet

If Selection.Rows.Count = 1 And Selection.Columns.Count > 1 Then

Call Multi_FillDown

Exit Sub

End If


If oWS.FilterMode = True Then

MsgBox "Please Unfilter Any Columns Before Running This Macro"

Exit Sub

End If

For i = Range(Selection, Selection).Row To Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

If Rows(i).Hidden = True Then

MsgBox "Please Unhide Any Rows Before Running This Macro"

Exit For

End If

Next


If WorksheetFunction.CountA(Cells) > 0 Then

frow = Cells.Find(What:="*", After:=[A1], _

SearchOrder:=xlByRows, _

SearchDirection:=xlPrevious).Row

End If

srow = Range(Selection, Selection).Row

col = Range(Selection, Selection).Column

Range(Cells(srow, col), Cells(frow, col)).Select

Selection.FillDown

Range(Cells(srow + 1, col), Cells(frow, col)).Copy

Range(Cells(srow + 1, col), Cells(frow, col)).Select

Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _

xlNone, SkipBlanks:=False, Transpose:=False

Application.CutCopyMode = False

Cells(srow, col).Select

SendKeys ("{ESC}")


Set oWS = Nothing

End Sub


Sub Multi_FillDown()

For Each Cell In Selection

Cell.Select

Call FillDown

Next

End Sub