Nested Loop to copy sheets

[bestie via OfficeKB.com]

Hello,

Im relativly new to VB and having some problems I hope someone can help me
with...

I have some master worksheets listed on a page called tree (they are in
coloumn H) which I wish to copy some of these have sub worksheets (also
listed on Tree) underneath in coloumn (i) which I would like to copy into the
same workbook. I have tried to do this below by using two loops but am not
sure if this is the best way to go about things as I think the loop is
causing it to snag on Worksheets(Sname$).Select as I have used this on
similar things and it works fine.

Any suggestions you caould give me would be great.

Thanks

Sam

Sub Copy and Paste()
'
' 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
Do While i < 50
' 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
Loop
End Sub