Thread: Need VBA formula to average dynamic ranges by column

My reports present their numerical data across the rows for columns D - AH
Using VBA macro, I need to insert a formula in each of the blank cells separating the ranges in order to average the range of cells above it by column. The ranges will vary in the number of rows between reports and can contain text. If needed I can add more blank rows between data sets.
D E F G etc....
4 4 5 2
2 5 n/a 4
_ _ _ _ <-- insert formulas in this row to average the range above in each column
3 2 4 5
2 n/a 4 3
9 3 3 2
_ _ _ _ <-- insert formulas in this row to average the range above in each column
and so on....

When all formulas are copied to the blank cells, each range then gets copied and pasted into its own worksheet; all ranges then begin with cell D2. (I have that code working). I need the formula to be copied with the data and work in the new worksheets.

The macro could simply fill the formula into all blank cells in the greater range D1-AH200 (preferred), or it could do it by columns, as I've tried with no success....

Sub insertFormula ()
Dim lngRow As Long
For lngRow = 2 To Cells(Rows.Count, "D").End(xlUp).Row
If (Range("D" & lngRow)) = "" And (Range("D" & lngRow + 1)) <> "" Then _
Range("D" & lngRow) . Formula = "=AVERAGE(Range("D" & lngRow + 1))"
Next
End Sub

Any help will be greatly appreciated. Thanks.

I'm doing this on the fly without testing, so back up first.

Assuming that each group that needs to be averaged is 4 rows

Sub insertFormula ()
    Dim lngRow As Long
    Dim lngCol as Long
    Dim lngLastRow as Long
    Dim r as Range

    For lngCol = Cells(1, "D").Column to Cells(1, "AH").Column
        lngLastRow = Cells(Rows.Count, lngCol).End(xlUp).Row + 1
        For lngRow = 2 To lngLastRow 
            Set r = Cells(lngRow, lngCol)
            If (r.Value = "" And r.Offset(1,0).Value <> "") _
                    or (lngRow = lngLastRow) _
                    Then 
                r.Formula = "=AVERAGE(Offset(" & r.Address & ",-4,0,4,1))"
            End If        
        Next lngRow
    Next lngCol
End Sub

The ".End(xlUp).Row + 1" needs the "+ 1" to put a formula below the last row of data.

Foxguy,

You are a genius. The routine ran beautifully, except foryour assumption that I needed only 4 rows averaged. That was the only hiccup. The ranges are of variable length within each report. If someone needed to do this with fixed ranges, they'd be set with your solution.

Thanks for helping me out..

BTW .. I modified your code when I realized it could also be used to error-check the raw data for blank cells. It finds and fills them all, which had been a real headache! Thanks again for your excellent solutions.

I wondered whether it would always be 4 rows, but your example showed the Average function was always on the same row for all the columns and the 2 groups you showed both had 4 rows.

It will take a little more time to have it determine how many rows to average. I have to run an errand. I'll be back in about an hour and set it up.

Sub insertFormula ()
    Dim lngRow As Long
    Dim lngCol as Long
    Dim lngLastRow as Long
    Dim r as Range
    Dim lRows as Long
    Dim s as String 

    For lngCol = Cells(1, "D").Column to Cells(1, "AH").Column
        lngLastRow = Cells(Rows.Count, lngCol).End(xlUp).Row + 1
        For lngRow = 2 To lngLastRow 
            Set r = Cells(lngRow, lngCol)
            If (r.Value = "" And r.Offset(1,0).Value <> "") _
                    or (lngRow = lngLastRow) _
                    Then 
                s = Replace(r.Address, "$", "")
                s = s & ",-" & lRows & ",0," & lRows & ",1"
                r.Formula = "=AVERAGE(Offset(" & s "))"
                lRows = 0
            Else
                lRows = lRows + 1
            End If        
        Next lngRow
    Next lngCol
End Sub

My 2¢:

Option Explicit

Sub GetBlankRow()
    Dim LastRow As Long, _
        TestCell As Range, _
        BlankRows As String
        
    LastRow = Sheets("sheet1").Cells(Rows.Count, "D").End(xlUp).Row + 1
    
    For Each TestCell In Range("D1:D" & LastRow)
        If TestCell = "" Then
            BlankRows = BlankRows & TestCell.Address(0, 0) & ","
        End If
    Next TestCell
    'strip off last comma
    BlankRows = Left(BlankRows, Len(BlankRows) - 1)
    WriteFormulas (BlankRows)
End Sub

Sub WriteFormulas(ByVal RowAddresses As String)

    Dim FormulaCell         As Range, _
        CellsToPutFormulas    As Variant, _
        RowPointer          As Long, _
        TopOfRange          As Long, _
        BottomOfRange       As Long, _
        ColToAvg, _
        AVGRange

    CellsToPutFormulas = Split(RowAddresses, ",")

    For RowPointer = 0 To UBound(CellsToPutFormulas)
        If RowPointer = 0 Then
            TopOfRange = 2
        Else
            TopOfRange = Sheets("sheet1").Range(CellsToPutFormulas(RowPointer - 1)).Row + 1
        End If
        BottomOfRange = Sheets("sheet1").Range(CellsToPutFormulas(RowPointer)).Row - 1

       For Each FormulaCell In Range(CellsToPutFormulas(RowPointer)).Resize(, 34)
            ColToAvg = FormulaCell.Column
            AVGRange = Range(Cells(TopOfRange, ColToAvg), Cells(BottomOfRange, ColToAvg)).Address(0, 0)
            FormulaCell.Value = "=AVERAGE(" & AVGRange & ")"
        Next FormulaCell

    Next RowPointer
End Sub

Ben;

A minor suggestion.

When I want to compile a list of comma separated strings, I do it this way.

BlankRows = BlankRows & "," & TestCell.Address(0, 0)

Then I strip off the 1st comma

BlankRows = Mid(BlankRows, 2)

That is very slightly faster because there is only one calculation (Mid) instead of 2 (Left & Len).