Macro to fill down for a range of cells

[tompepper]

HI,
Each day I enter data in the data columns and later I manually click fill down for the formulas. I then click Shift and Up Arrow so it leaves the filled cells (apart from the bottom row) selected, then I click Copy and Paste Special-Values.
I want to use a macro to fill down, So go to the last row of formulas, selecting the cells in the row with formulas and filling down to the last row with data, then with those cells selected, deselect the bottom row of formula cells and copy and paste values for the selected cells.. The row number changes each day and I've not been able to make it work by recording a macro.


Thanks

 

[CephasOz]

Try this. Just select the area that you want to have filled (with an example row at the top), and it will fill down for each column that you permit. If it encounters other values on the way down, it will start using those to fill down. (Try it out on a worksheet with dummy data so you can see what's happening.)

' When a column has missing values, copy the previous value into the next row.
Sub FillDown()
    Const cstrTitle As String = "FillDown"
    Const clngStartRow As Long = 2
    Dim strErrMsg As String
    Dim strMsg As String
    Dim lngCol As Long
    Dim strCol As String
    Dim rngArea As Range
    Dim rngToUse As Range
    Dim rngCell As Range
    Dim varToCopy As Variant
    Dim strFormat As String
    Dim strFormula As String
    Dim vbmStyle As VbMsgBoxStyle
    Dim vbmResult As VbMsgBoxResult
    Dim strAddress As String
    Dim lngAlign As xlhAlign
    '
    On Error GoTo Err_Exit
    '
    vbmStyle = vbYesNo + vbDefaultButton2 + vbQuestion
    For Each rngArea In Selection.Areas
        Set rngToUse = Application.Intersect(Selection.Parent.UsedRange, rngArea)
        For lngCol = 1 To rngToUse.Columns.Count
            strAddress = rngToUse.Cells(1, lngCol).Address(True, False)
            strCol = Left(strAddress, InStr(strAddress, "$") - 1)
            strMsg = "Fill down the values in column " & strCol & "?"
            vbmResult = MsgBox(strMsg, vbmStyle, cstrTitle)
            If (vbmResult = vbYes) Then
                varToCopy = Null
                strFormat = vbNullString
                strFormula = vbNullString
                For Each rngCell In rngToUse.Columns(lngCol).Cells
                    With rngCell
                        If (.Row >= clngStartRow) Then
                            If IsEmpty(rngCell) Then
                                If (Not IsNull(varToCopy)) Then
                                    If (Trim(strFormat) <> vbNullString) Then
                                        .NumberFormat = strFormat
                                    End If
                                    If (Trim(strFormula) = vbNullString) Then
                                        .Value = varToCopy
                                    Else
                                        .Formula2R1C1 = strFormula
                                    End If
                                    .HorizontalAlignment = lngAlign
                                End If
                            Else
                                varToCopy = .Value
                                strFormat = .NumberFormat
                                strFormula = .Formula2R1C1
                                lngAlign = .HorizontalAlignment
                            End If
                        End If
                    End With
                Next
            End If
        Next
    Next
    '
Housekeeping:
    Set rngCell = Nothing
    Set rngToUse = Nothing
    Set rngArea = Nothing
    Exit Sub
Err_Exit:
    strErrMsg = Err.Number & ": " & Err.Description
    Err.Clear
    MsgBox strErrMsg, vbCritical + vbOKOnly, cstrTitle
    Resume Housekeeping
End Sub

 

[tompepper]

That didn't work for me. It popped up a message asking to fill down for each column I selected, so 10 messages if I select 10 columns but didn't fill down. Maybe I can specify which columns to fill down in the macro and then just run the macro and it completes?

 

[CephasOz]

Just select the area that you want to have filled (with an example row at the top)

Don't select entire columns. Just select a rectangle of cells where you want the fill to happen. The top selected row should have some values to fill down.

 

[CephasOz]

... and if you want it to fill down without asking, you can just remove the MsgBox and the If/End If for the MsgBox.

 

[tompepper]

Is there a way have the macro automatically go to the correct cells to fill down and then complete the other actions I noted?

 

[CephasOz]

Okay, automatic fill it is. See if this meets your needs.

' When a cell is empty, copy the previous value.
Sub FillDown2()
    Const cstrTitle As String = "FillDown2"
    Dim strErrMsg As String
    Dim rngRow As Range
    Dim rngCell As Range
    Dim xlcPrev As XlCalculation
    Dim bolUpdating As Boolean
    '
    strErrMsg = vbNullString
    xlcPrev = Application.Calculation
    Application.Calculation = xlCalculationManual
    bolUpdating = Application.ScreenUpdating
    Application.ScreenUpdating = False
    '
    On Error GoTo Err_Exit
    '
    For Each rngRow In ActiveSheet.UsedRange.Rows
        If (rngRow.Cells(1).Row > 1) Then
            For Each rngCell In rngRow.Cells
                If IsEmpty(rngCell.Value) Then
                    rngCell.Offset(-1).Copy Destination:=rngCell
                End If
            Next
        End If
    Next
    '
Housekeeping:
    Application.Calculation = xlcPrev
    Application.ScreenUpdating = bolUpdating
    '
    If (strErrMsg <> vbNullString) Then
        MsgBox strErrMsg, vbCritical + vbOKOnly, cstrTitle
    End If
    '
    Set rngCell = Nothing
    Set rngRow = Nothing
    Exit Sub
Err_Exit:
    strErrMsg = Err.Number & ": " & Err.Description
    Err.Clear
    Resume Housekeeping
End Sub

 

[tompepper]

I get an error saying can't copy contents of clipboard as its in use by another program and Excel crashes

 

[CephasOz]

I'm sorry, I can't help you with that. The code itself is solid, because it runs fine on my computer. It doesn't use anything that you wouldn't have access to in Office 2013, so it's not that. I have changed the code so that it doesn't use copy, because your error message indicates a problem on your computer. See if this does the job.

Sub FillDown2()
    Const cstrTitle As String = "FillDown2"
    Dim strErrMsg As String
    Dim rngRow As Range
    Dim rngCell As Range
    Dim xlcPrev As XlCalculation
    Dim bolUpdating As Boolean
    '
    strErrMsg = vbNullString
    xlcPrev = Application.Calculation
    Application.Calculation = xlCalculationManual
    bolUpdating = Application.ScreenUpdating
    Application.ScreenUpdating = False
    '
    On Error GoTo Err_Exit
    '
    For Each rngRow In ActiveSheet.UsedRange.Rows
        If (rngRow.Cells(1).Row > 1) Then
            For Each rngCell In rngRow.Cells
                If IsEmpty(rngCell.Value) Then
                    With rngCell.Offset(-1)
                        rngCell.NumberFormat = .NumberFormat
                        rngCell.Formula2R1C1 = .Formula2R1C1
                        rngCell.HorizontalAlignment = .HorizontalAlignment
                        rngCell.Value = .Value
                    End With
                End If
            Next
        End If
    Next
    '
Housekeeping:
    Application.Calculation = xlcPrev
    Application.ScreenUpdating = bolUpdating
    '
    If (strErrMsg <> vbNullString) Then
        MsgBox strErrMsg, vbCritical + vbOKOnly, cstrTitle
    End If
    '
    Set rngCell = Nothing
    Set rngRow = Nothing
    Exit Sub
Err_Exit:
    strErrMsg = Err.Number & ": " & Err.Description
    Err.Clear
    Resume Housekeeping
End Sub

 

[tompepper]

I'm sorry, I can't help you with that. The code itself is solid, because it runs fine on my computer. It doesn't use anything that you wouldn't have access to in Office 2013, so it's not that. I have changed the code so that it doesn't use copy, because your error message indicates a problem on your computer. See if this does the job.

Sub FillDown2()
    Const cstrTitle As String = "FillDown2"
    Dim strErrMsg As String
    Dim rngRow As Range
    Dim rngCell As Range
    Dim xlcPrev As XlCalculation
    Dim bolUpdating As Boolean
    '
    strErrMsg = vbNullString
    xlcPrev = Application.Calculation
    Application.Calculation = xlCalculationManual
    bolUpdating = Application.ScreenUpdating
    Application.ScreenUpdating = False
    '
    On Error GoTo Err_Exit
    '
    For Each rngRow In ActiveSheet.UsedRange.Rows
        If (rngRow.Cells(1).Row > 1) Then
            For Each rngCell In rngRow.Cells
                If IsEmpty(rngCell.Value) Then
                    With rngCell.Offset(-1)
                        rngCell.NumberFormat = .NumberFormat
                        rngCell.Formula2R1C1 = .Formula2R1C1
                        rngCell.HorizontalAlignment = .HorizontalAlignment
                        rngCell.Value = .Value
                    End With
                End If
            Next
        End If
    Next
    '
Housekeeping:
    Application.Calculation = xlcPrev
    Application.ScreenUpdating = bolUpdating
    '
    If (strErrMsg <> vbNullString) Then
        MsgBox strErrMsg, vbCritical + vbOKOnly, cstrTitle
    End If
    '
    Set rngCell = Nothing
    Set rngRow = Nothing
    Exit Sub
Err_Exit:
    strErrMsg = Err.Number & ": " & Err.Description
    Err.Clear
    Resume Housekeeping
End Sub

Thanks for trying, Excel just hangs when I run this.