HI,
The following code may help.
Code:
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
Bookmarks