Subtotals using Macro ...

[JohnyG]

Hi,

Need a help. I have the following code that picks the subtotal (Sheet4) and paste in (sheet5)...

[VBA]Sub CopySubTotals()
Dim Src As Worksheet, Tgt As Worksheet, R1 As Range, R2 As Range

Set Src = Sheets("Sheet4")
Set Tgt = Sheets("Sheet5")
Src.Outline.ShowLevels 3
Set R1 = Src.Range("B1").End(xlDown)
Do
Set R2 = Tgt.Range("A" & Tgt.Rows.Count).End(xlUp).Offset(1)
R2 = R1
R2.Offset(, 1) = R1.Offset(1, 1)
R2.Offset(, 2) = R1.Offset(1, 2)
R2.Offset(, 2) = R1.Offset(1, 5)
Set R1 = R1.End(xlDown).End(xlDown)
Loop While R1.Row < Src.Rows.Count
End Sub[/VBA]

Now the issue is at certain stage for example ... Row 29 sheet5 it started picking wrong values and instead of subtotals the macro starts picking other values. Effectively it started from row 776 (sheet4)...

Can someone please help me on this ..

Regards,

[JimmyTheHand]

Wasn't taken into consideration that list of a company can be 1 rows high.
Try this:
[VBA]Sub CopySubTotals()
Dim Src As Worksheet, Tgt As Worksheet, R1 As Range, R2 As Range

Set Src = Sheets("Sheet4")
Set Tgt = Sheets("Sheet5")
Src.Outline.ShowLevels 3
Set R1 = Src.Range("B1").End(xlDown)
On Error Resume Next
Do
Set R2 = Tgt.Range("A" & Tgt.Rows.Count).End(xlUp).Offset(1)
R2 = R1
R2.Offset(, 1) = R1.Offset(1, 1)
R2.Offset(, 2) = R1.Offset(1, 2)
R2.Offset(, 2) = R1.Offset(1, 5)

Set R1 = R1.End(xlDown)
If R1.Offset(1) <> "" Then Set R1 = R1.End(xlDown)
Loop While R1.Row < Src.Rows.Count
End Sub
[/VBA]

Jimmy

[JohnyG]

Thank you sir..

That did the needful..

Regards,