Copy and Paste using a loop

[bestie via OfficeKB.com]

Hello,

I'm having some problems with a copy and paste routine I hope you can help me
with. I am trying to copy a number of header sheets from col (H) and the sub
sheets that are listed under them in col (I) into separate workbooks. All the
sheet names are listed on a sheet called tree but the way I've done it seems
slightly clumsy and I was hoping some one had a smarter way of doing this....

Thanks

Sub Copyheader()
' grid Macro
' Macro recorded 27/07/2006 by Sam Best

'

Dim i As Long
Dim nRow As Long
Dim Sname$
Dim ThisPath As String
Dim FullPath As String
' selects each sheet name down the list & activates that sheet
i = 10
If i < 50 Then
' stops at cell 50

With Sheets("TREE")
If IsEmpty(.Cells(i, "H").Value) Then
i = i + 1
' If nothing in the heading then keep looking untill there is something
in the heading

Else: Sname$ = Cells(i, "H")
Worksheets(Sname$).Select
' If cell is a heading then select sheet with heading name

FullPath = ThisPath & "\" & "Property - " & ShName & ".xls"

Call DeleteIfExists(FullPath)

Sheets(Sname$).Copy
ActiveWorkbook.SaveAs FullPath
ThisWorkbook.Activate
' Copy sheet and and return to the master workbook

errortrap:

MsgBox "Sheet - " & ShName & " Could not be copied" & Chr(10) & Chr
(10) & Err.Description, vbCritical
' Reports Errors


Do While Not IsEmpty(.Cells(i, "i").Value)
Sname$ = Cells(i, "i")
' passes the sheet name to routine

Worksheets(Sname$).Select
' selects sheet
Sheets(Sname$).Copy
ThisWorkbook.Activate
i = i + 1
Loop
i = i + 1
' Moves to next cell

Sheets("Tree").Select
' Selects Tree Sheet


End If
End With
End If
End Sub