VBA code to add repeat formula to each blank row

[windb]

Hi there,

I'm trying to add a formula into each blank row of my data set in column C. (see cell C5 on image, as an example of where the formula has populated, and cell C11 where it hasn't)

The formula in column C is a weighted sum product formula i.e. =($B3*C3)+($B4*C4)+($B5*C5), so this returns the weighted sum of the values, where B3, B4 and B5= percentage amounts
And C3, C4 and C5 are numerical values
(The sum product could also work here, I believe)

However, the issue I'm having is that each 'record' has a different number of parts, i.e. percentage amounts assigned to the record, so the calculation varies each time. E.g. Record 2 may only need to 'count' the sum product of 2 parts/ rows, whereas record 4 may have 4 parts/ rows.

I need the formula (VBA?) to insert the correct formula for each blank row all the way down. e.g. the formula on row 8 would need to be =($B6*C6)+($B7*C7) only. I could manually go down the list and amend the formulas but I have several hundred records, so just trying to consider if there is a more efficient way of doing this.

Many thanks!

 

[BSALV]

Sub copy_formula()
     Dim c     As Range

     With ActiveSheet
          With .Range(.Range("A1"), .Range("A" & Rows.Count).End(xlUp))     'that part of the A-column
               On Error Resume Next
               Set c = .SpecialCells(xlConstants)               'all cells filled with constants (= no formulas or blank cells)
               On Error GoTo 0
               If c Is Nothing Then MsgBox "no constants", vbCritical: Exit Sub

               For Each ar In c.Areas                           'loop through the blocks of such cells
                    With ar.Cells(ar.Rows.Count + 1, 1)         'next cell afther such a block
                         If WorksheetFunction.CountA(.Resize(, 2)) = 0 Then     ' A en B are empty
                              .Offset(, 2).Formula = "=sumproduct((" & ar.Offset(, 1).Address(0, 1) & ")*(" & ar.Offset(, 2).Address(0, 0) & "))"     'this formula in C
                              .Offset(, 3).Formula = "=sumproduct((" & ar.Offset(, 1).Address(0, 1) & ")*(" & ar.Offset(, 3).Address(0, 0) & "))"     'this formula in D
                         End If
                    End With
               Next
          End With
     End With

End Sub

 

[windb]

Sub copy_formula()
     Dim c     As Range

     With ActiveSheet
          With .Range(.Range("A1"), .Range("A" & Rows.Count).End(xlUp))     'that part of the A-column
               On Error Resume Next
               Set c = .SpecialCells(xlConstants)               'all cells filled with constants (= no formulas or blank cells)
               On Error GoTo 0
               If c Is Nothing Then MsgBox "no constants", vbCritical: Exit Sub

               For Each ar In c.Areas                           'loop through the blocks of such cells
                    With ar.Cells(ar.Rows.Count + 1, 1)         'next cell afther such a block
                         If WorksheetFunction.CountA(.Resize(, 2)) = 0 Then     ' A en B are empty
                              .Offset(, 2).Formula = "=sumproduct((" & ar.Offset(, 1).Address(0, 1) & ")*(" & ar.Offset(, 2).Address(0, 0) & "))"     'this formula in C
                              .Offset(, 3).Formula = "=sumproduct((" & ar.Offset(, 1).Address(0, 1) & ")*(" & ar.Offset(, 3).Address(0, 0) & "))"     'this formula in D
                         End If
                    End With
               Next
          End With
     End With

End Sub

Brilliant; works a treat - thank you very much. It seems to throw up an error on the very first sum product calculation, e.g. row 5 in the example provided but not a huge issue. Just flagging in case you were interested to understand the reason for this! Really great stuff. Thanks again 'BSALV'.

 

[BSALV]

To exclude the headerrow with the titles, you start at the 2nd line = A2 instead of A1.
So change this line in the macro

          With .Range(.Range("A2"), .Range("A" & Rows.Count).End(xlUp))     'that part of the A-column

 

[windb]

To exclude the headerrow with the titles, you start at the 2nd line = A2 instead of A1.
So change this line in the macro

          With .Range(.Range("A2"), .Range("A" & Rows.Count).End(xlUp))     'that part of the A-column

Excellent. Thanks again for your help.

 

[BSALV]

you're welcome