VBA Code to extract subtotals

[Charles]

HI,

The following code may help.

Sub Total_Extraction()
Application.ScreenUpdating = False
Dim c As Variant
Dim Ffind As Long
Dim Slrow As Long
''' Doing seach for the formula "SubTotal ''
With Sheets("Sheet1").Range("B1:B" & Sheets("Sheet1").Range("B65536").End(xlUp).Row)
    Set c = .Find("SUBTOTAL", Lookat:=xlPart)
    If Not c Is Nothing Then
        '''' get row nr and Value in cell copy to sheet2 ''
        Ffind = c.Row
        '' See if value < 0 '' if it is finish code''
        If Cells(c.Row, 2).Value < 0 Then
            Slrow = Sheets("Sheet2").Range("A65536").End(xlUp).Row + 1
            Sheets("Sheet2").Range("A" & Slrow).Value = c.Row
            Sheets("Sheet2").Range("B" & Slrow).Value = Sheets("Sheet1").Cells(c.Row, 2).Value
        End If
        Do
            Set c = .FindNext(c)
            If c.Row = Ffind Then Exit Sub
            If Cells(c.Row, 2).Value < 0 Then
            Slrow = Sheets("Sheet2").Range("A65536").End(xlUp).Row + 1
            Sheets("Sheet2").Range("A" & Slrow).Value = c.Row
            Sheets("Sheet2").Range("B" & Slrow).Value = Sheets("Sheet1").Cells(c.Row, 2).Value
        End If
        Loop While c.Row <> Ffind
    End If
End With

End Sub