VBA to find last row of a unique value and insert formulas

[sfoc]

Hi Everyone,

I'm working with a worksheet which has 10 columns - A thru J...several thousand rows of data. Column A contains the unique identifier (ID#). Data is sorted by column A.

Instead of manually finding the last row for each unique ID, is there a way to automate the process of finding the last row for each unique value in column A, and then inserting a row with formula in columns E thru I to sum the values above for each unique ID?

Thank you!

[TMS]

You don't need VBA. This article explains how: Insert subtotals in a list of data in a worksheet

See: https://support.microsoft.com/en-us/...e-b0a3d4a52b3a

[sfoc]

Thank you, that definitely worked but I failed to mention in my original post that column J would need a different formula to divide column I's result by column E.

[TMS]

If you want code, you need to post data.


Fast answers need visual help. Please read the yellow banner at the top of this page on how to attach a file and a mocked up solution.

[mohadin]

Hi
Assumed your data's start A1 & row1 is headers
Try

Sub test()
Dim a, w
Dim i&, ii&, c&
   Application.ScreenUpdating = False
With CreateObject("scripting.dictionary")
    .comparemode = 1
    For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
        If Not .exists(Cells(i, 1).Value) Then
            .Add (Cells(i, 1).Value), Array(Cells(i, 1).Address, 1)
        Else
            w = .Item(Cells(i, 1).Value): w(1) = w(1) + 1: .Item(Cells(i, 1).Value) = w
        End If
    Next
    w = .Items:  ii = .Count - 1
  End With
     For i = ii To 1 Step -1
     With ActiveSheet.Range(w(i)(0)).Offset(w(i)(1))
       .EntireRow.Insert
       .Offset(-1, 4).Resize(, 5).FormulaR1C1 = "=SUM(R[-" & w(i)(1) & "]C:R[-1]C)"
       .Offset(-1, 9).FormulaR1C1 = "=RC[-1]/RC[-5]"
    End With
    Next
    Application.ScreenUpdating = True
End Sub