CODEWITHSUNDEEP
excelvba
abc
abc

Reputation: 429

filldown formula down to last visible cell

My code to filldown a formula to only visible cells in a column mostly works, but its also copying down formatting such as strikethrough which is not intended. Furthermore, it is also filling down beyond the last visible row.

With ActiveSheet.UsedRange
    .Resize(.Rows.count - 1).Offset(1).Columns("H").SpecialCells(xlCellTypeVisible).FillDown
End With

'Deletes excess data as the filldown is going beyond the last visible row
On Error Resume Next
ActiveSheet.Columns("A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete

Here's the formula in Cell H3 if it helps:

=IF(Q3="1",G3+30,IF(Q3="12",G3+365-1,IF(Q3="24",G3+730-1,IF(Q3="36",G3+1095-1,IF(Q3="3",G3+90-1,IF(Q3="32",G3+973-1,"NA"))))))

Upvotes: 1

Views: 70

Answers (1)

VBasic2008
VBasic2008

Reputation: 54983

Delete Rows (SpecialCells) and Fill Down Formula

  • If it is assumed that a blank cell is either an empty cell, or contains a single quote ' or contains a formula evaluating to "", the last two making it appear as empty, then, although it 'says' xlCellTypeBlanks, it rather refers only to empty cells.

The Code

Option Explicit

Sub fillDownFormula()
    
    ' It is assumed that the first 'data' cell ('FirstCell') is not empty
    ' and that the cell in the same row of the destination column
    ' contains a formula.
    
    Const FirstCell As String = "A3"
    Const dstCol As String = "H" ' Destination Column
    
    ' Define Source Range (and column offset).
    Dim rg As Range
    Dim colOffset As Long
    With ActiveSheet.Range(FirstCell)
        Set rg = .Resize(.Worksheet.Rows.Count - .Row + 1) _
            .Find("*", , xlFormulas, , , xlPrevious)
        If rg Is Nothing Then Exit Sub
        Set rg = .Resize(rg.Row - .Row + 1)
        colOffset = .Worksheet.Columns(dstCol).Column - .Column
    End With
    
    Application.ScreenUpdating = False
    
    ' Delete rows containing empty cells in column of first cell.
    On Error Resume Next ' Prevent error if no cells to delete.
    rg.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    On Error GoTo 0
    
    ' Apply 'FillDown' in Destination Column.
    rg.Offset(, colOffset).FillDown

    Application.ScreenUpdating = True ' before 'MsgBox'

    MsgBox "Formula filled down.", vbInformation, "Success"

End Sub

Upvotes: 1

Related Questions