Loop help

Hello all,

I created (recorded) a macro to sort and subtotal raw data with the following:

Sub SubtotalBalSheet()
'
' SubtotalBalSheet Macro
' Macro recorded 10/15/2004 by A24479
'

'
Rows("1:1").Select
Selection.Insert Shift:=xlDown
Range("A1").Select
ActiveCell.FormulaR1C1 = "G/L"
Range("B1").Select
ActiveCell.FormulaR1C1 = "Branch"
Range("C1").Select
ActiveCell.FormulaR1C1 = "Description"
Range("D1").Select
ActiveCell.FormulaR1C1 = "Current Month"
Range("E1").Select
ActiveCell.FormulaR1C1 = "Prior Month"
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Font.Bold = True
Range(Selection, Selection.End(xlDown)).Select
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, HEADER:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Cells.Select
Cells.EntireColumn.AutoFit
Columns("D").Select
Selection.Style = "Comma"
Columns("E:E").Select
Selection.Style = "Comma"
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(4, 5), _
Replace:=True, PageBreaks:=False, SummaryBelowData:=True
Range("C1").Select

This portion seems to work well. The next section is where it goes south:

Do Until counter =6000
counter = counter + 1
Selection.End(xlDown).Select
Selection.Copy
Selection.Offset(1, 0).Select
ActiveSheet.Paste
If counter = 6000 Then Exit Do
Loop
Range("A1").Select
End Sub

Once the loop gets to row 65536 it breaks. I've tried to make the loop stop
before that row, but I haven't been able to figure out how. Any help will be
greatly appreciated.

Chris