try this code

Sub CreateWorkbooks()
Dim wS As Worksheet
Dim wbA As Workbook
Dim wbB As Workbook
Dim wbNew As Workbook
Dim sPath As String
Dim sFname As String
Dim i4Cnt As Integer

Set wbA = WorkBooks("BookA.xls")
Set wbB = WorkBooks("BookB.xls")
sPath = "D:\My Documents\"
For Each wS In Worksheets
sFname = wS.Name
wS.Copy
Set wbNew = ActiveWorkbook
For i4Cnt = 1 To wbB.Sheets.Count Step 1
wbB.Sheets(i4Cnt).Copy After:=wbNew.Sheets(wbNew.Sheets.Count)
Next i4Cnt
wbNew.SaveAs Filename:=sPath & sFname & ".xls", FileFormat:= _
xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False _
, CreateBackup:=False
wbNew.Close
Next wS

End Sub

You can also replace my i4Cnt loop with either one of these 2 lines of
code
Sheets(Array("Sheet1", "Sheet2", "Sheet3")).Copy
Sheets(Array(1, 2, 3)).Copy


--
mudraker
------------------------------------------------------------------------
mudraker's Profile: http://www.excelforum.com/member.php...fo&userid=2473
View this thread: http://www.excelforum.com/showthread...hreadid=535810