向下填充公式到最后一个可见单元格

Question

我的代码仅将公式填充到列中的可见单元格大部分都有效，但它也复制了格式，例如删除线，这是不打算的。此外，它还在最后一个可见行之外填充。

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

如果有帮助，这里是单元格 H3 中的公式：

=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"))))))

Answer 1

删除行 (SpecialCells) 并填写公式

• 如果假定空白单元格是空单元格，或包含单引号 ' 或包含计算结果为“”的公式，则最后两个使其显示为空，然后，尽管它“说” xlCellTypeBlanks，它仅指空单元格。

守则

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