Need help with this VBA for Subtotal

[MikeL]

Hello,
Got stuck as I running the VBA below incorrectly replaces the subtotal. I would like to modify the subtotal to be based off col D. Any thoughts?

Sub Test()
'Subtotal Formula
currow = ActiveCell.Row
firstrow = ActiveCell.End(xlUp).End(xlUp).Row
diff = currow - firstrow

For Each cell In Range("d1:d" & Cells(Rows.Count, "d").End(xlUp).Row)
If InStr(cell.Text, "Subtotal") > 0 Then

cell.Offset(0, 5).Select
ActiveCell.FormulaR1C1 = "=SUBTOTAL(9,R[-" & diff & "]C:R[-1]C)"

End If
Next cell
MsgBox ("complete")
End Sub


--------------------------

Fruit and Veggies4.xlsm
	A	B	C	D	E	F	G	H	I
1	VEGETABLES
2		BEANS							5,000
3
4		CARROTS							6,000
5				Subtotal VEGGIES					11,000
6
7
8
9	FRUIT
10		BERRIES							5,000
11
12		ORANGES							6,000
13
14		KIWI							700
15
16		APPLES							1,000
17				Subtotal FRUIT					12,700
Sheet1

Cell Formulas
Range	Formula
I5	I5	=SUBTOTAL(9,I2:I4)
I17	I17	=SUBTOTAL(9,I10:I16)

 

[Osvaldo Palmeiro]

Hi. Please, try this code.

Sub Test()
 Dim rng As Range, c As Range, fst As String, k As Long
  Set rng = Range("D2:D" & Cells(Rows.Count, 4).End(3).Row)
  Set c = rng.Find("Subtotal*") 
   If Not c Is Nothing Then
    fst = c.Address: k = [I1].End(4).Row
    Do
     c.Offset(, 5).Formula = "=SUBTOTAL(9,I" & k & ":I" & c.Row - 1 & ")"
     k = Cells(c.Row, "I").End(4).Row
     Set c = rng.FindNext(c)
    Loop While Not c Is Nothing And c.Address <> fst
   End If
End Sub

 

[MikeL]

Hi. Please, try this code.

Sub Test()
 Dim rng As Range, c As Range, fst As String, k As Long
  Set rng = Range("D2:D" & Cells(Rows.Count, 4).End(3).Row)
  Set c = rng.Find("Subtotal*")
   If Not c Is Nothing Then
    fst = c.Address: k = [I1].End(4).Row
    Do
     c.Offset(, 5).Formula = "=SUBTOTAL(9,I" & k & ":I" & c.Row - 1 & ")"
     k = Cells(c.Row, "I").End(4).Row
     Set c = rng.FindNext(c)
    Loop While Not c Is Nothing And c.Address <> fst
   End If
End Sub

Thanks!