Auto applying formula to clusters of data which loops

[james1996]

Hello,

I'd like to know how do I get all of the lines above the bottom cell to also be multiplied by BottomCell.Offset(1, 2)?

I am referring to the text highlighted in blue - As you can see I am multiplying the bottom cell by BottomCell.Offset(1, 2).


Dim Rng As Range
Dim Wrng As Range
On Error Resume Next
xTitleId = "Test"
Set Wrng = Application.Selection
Set Wrng = Application.InputBox("Range", xTitleId, Wrng.Address, Type:=8)
Application.ScreenUpdating = False
For i = Wrng.Rows.count To 2 Step -1
If Wrng.Cells(i, 1).Value <> Wrng.Cells(i - 1, 1).Value Then
Wrng.Cells(i, 1).EntireRow.Insert
Wrng.Cells(i, 1).EntireRow.Insert


End If
Next
Application.ScreenUpdating = True

Range("C1").Select

Dim rngToSum As Range
Dim TopCell As Range
Dim BottomCell As Range

Set rngToSum = Intersect(Selection.EntireColumn, ActiveSheet.UsedRange)
Set TopCell = rngToSum.Cells(1, 1)
If TopCell.Value = vbNullString Then
Set TopCell = TopCell.End(xlDown)
End If
Do
Set BottomCell = TopCell.End(xlDown)
BottomCell.Offset(1, 0).Formula = "=sum(" & Range(TopCell, BottomCell).Address & ")"
BottomCell.Offset(1, 1).FormulaR1C1 = "=VLOOKUP(R[-2]C[-2],C[8]:C[9],2,0)"
BottomCell.Offset(1, 2).FormulaR1C1 = "=RC[-1]/RC[-2]"
BottomCell.Offset(0, 2).Formula = BottomCell * BottomCell.Offset(1, 2)

Set TopCell = BottomCell.Offset(1, 0).End(xlDown)
Loop Until Intersect(rngToSum, TopCell) Is Nothing

This is what the code does:

What I would like is for the code to multiply each line by BottomCell.Offset(1, 2)

Thanks!
James

 

[james1996]

?