Sub TotCols()
Range("A1").Offset(Range("A1").CurrentRegion.Rows.Count, 2).FormulaR1C1 = "=subtotal(9,R[-" & Range("A1").CurrentRegion.Rows.Count & "]C:R[-1]C)"
Range("A1").Offset(Range("A1").CurrentRegion.Rows.Count - 1, 3).FormulaR1C1 = "=max(R[-" & Range("A1").CurrentRegion.Rows.Count - 1 & "]C:R[-1]C)"
End Sub
Sub SubTot()
Dim x As Long
'Set Rng = Range("A1:A" & UsedRange.Rows.Count)
a = 2
b = 2
For i = 2 To ActiveSheet.Rows.Count
If Range("A" & i).Value = "" Then Exit For
If Range("A" & i).Value <> Range("A" & i + 1).Value Or _
Range("B" & i).Value <> Range("B" & i + 1).Value Then
Rows(i + 1 & ":" & i + 3).Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A" & i + 1).Value = "----------"
Range("A" & i + 2).Value = "Subtotal " & Range("B" & i).Value
Range("C" & i + 2).Value = "=SUM(C" & b & ":C" & i & ")"
Range("D" & i + 2).Value = "=MAX(D" & b & ":D" & i & ")"
If Range("A" & i).Value <> Range("A" & i + 4).Value Then
Rows(i + 4 & ":" & i + 6).Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A" & i + 4).Value = "----------"
Range("A" & i + 5).Value = "total " & Range("A" & i).Value
Range("C" & i + 5).Value = "=SUM(C" & a & ":C" & i + 2 & ")/2"
Range("D" & i + 5).Value = "=MAX(D" & a & ":D" & i & ")"
Range("A" & i + 6).Value = "----------"
i = i + 6
a = i + 1
b = i + 1
Else
i = i + 3
b = i + 1
End If
End If
Next i
If you are experiencing a similar issue, please ask a related question
Title | # Comments | Views | Activity |
---|---|---|---|
Extract Names Based on Position in the Column | 12 | 33 | |
locking multiple column ranges | 10 | 25 | |
Excel filter on tab not showing any entries? | 5 | 23 | |
VBA to add shapes inside a chart | 9 | 20 |
Join the community of 500,000 technology professionals and ask your questions.