Copy Sheets

[Edgar]

Hi

I have a workbook with an index page with the following
columns

Sheet No Sheet Name Product Copied
1 AU25223 Austravel Y
2 TP52214 Tropical
etc

I have written the following code which copies sheets from
this workbook to other workbooks depending on the value in
column PRODUCT.

This all works fine but at the moment it just works it way
through the list copying the workbooks as it goes. My
problem is that if there are 10 lines with product
Austravel on it - it will open up 10 different copies of
Austravel.xls and then copy the sheet and then close and
then move on to the next one. What I would ideally like is
it to copy all sheets for Austravel in one hit.

Does anyone know how I can do this?

TIA


Sub Copy_Sheets()
Dim shName As String
Dim prName As String
Dim CValue As Range
Dim Cell As Range
Dim owb As Workbook

With Worksheets("Index")
For Each Cell In Range("D39")
If Cell.Value = "" Then
shName = Cell.Offset(0, -2).Text
prName = Cell.Offset(0, -1).Text

Select Case prName
Case "Austravel"
prloc = "S:\Kingston\FA\Overseas Payments\Overseas
Payments Public\Remittance\Long Haul\Austravel\Austravel
Crystal Export File.xls"
fname = "Austravel Crystal Export File.xls"
Case "Tropical"
prloc = "S:\Kingston\FA\Overseas Payments\Overseas
Payments Public\Remittance\Long Haul\Tropical\Tropical
Crystal Export File.xls"
fname = "Tropical Crystal Export File.xls"
Case "Jetsave"
prloc = "S:\Kingston\FA\Overseas Payments\Overseas
Payments Public\Remittance\Long Haul\Jetsave\Jetsave
Crystal Export File.xls"
fname = "Jetsave Crystal Export File.xls"
End Select

With Application
..DisplayAlerts = False
..DisplayAlerts = False
End With

Set owb = Workbooks.Open(prloc)
Workbooks("LH Crystal Export File.xls").Activate
Sheets(shName).Copy Before:=Workbooks(fname).Sheets(1)
Cell.Value = "Y"

With Application
..DisplayAlerts = False
..DisplayAlerts = False
End With

Workbooks(fname).Save
Workbooks(fname).Close

End If
Next Cell
End With

End Sub