Copying SubTotal Rows Only

[Factor 21]

Hi,

I have the following code for copying "SubTotaled" Rows to a new work sheet, which works fine, my problem is now I have three columns which are SubTotaled and the code copies the row three times, Can anyone help amend the code to only copy the row once to the new sheet?

Public Sub copy_subtotals()

Dim ws As Worksheet
Dim ws2 As Worksheet
Dim My_Result As Variant
Dim First_Address As Variant

Set ws = ActiveSheet
Set ws2 = Worksheets("Totals") 'change this to suit your workbook.

With ws
Set My_Result = .Cells.Find("subtotal", [A1], LookIn:=xlFormulas)
If Not My_Result Is Nothing Then
First_Address = My_Result.Address
Do
My_Result.EntireRow.Copy
ws2.Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
Set My_Result = .Cells.FindNext(My_Result)
Loop While (Not My_Result Is Nothing) And (First_Address <> My_Result.Address)
End If

End With
Application.CutCopyMode = False


End Sub

Thanks in advance

Jeremy
__________________________________________________________________

Mod edit : thread moved to appropriate forum !​

 

[Debaser]

If you added the subtotals using the Data-Subtotal feature, it's probably easier to collapse the outline to show the level you want and then just copy the visible cells.