VBA Code to extract subtotals

[Howardc]

I am looking for VBA code to extract the row number and sub-total in Col B in sheet 1, where the value is not zero for eg if the sub-total value is for eg 50, -50 etc., but to ignore zeroes

I would like row numbers containing the sub-total values that are not zero to be extracted to sheet2.

I have manually extracted the Row # in Col A and the value in Col B on Sheet2 to give an idea of what the extraction must look like

Your assistance in this regard is most appreciated


VBA Code to extract subtotals (http://www.mrexcel.com/forum/excel-questions/672207-visual-basic-applications-code-extract-subtotals.html#post3330286)

[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

[Howardc]

Hi Charles

Thanks for the help, much appreciated

I made one small change , I needed to include positive and negative calues <> zero -see snippet of code below


If Cells(c.Row, 2).Value <> 0 Then ....

If Cells(c.Row, 2).Value <> 0 Then .....

Are there any good VBA books your can recommend for novices?