Copy sheets to new file and rename it

Hi everybody,
Without experience in programming I need help from you, everyone who could help me.
I have 50 worksheets in 1 workbook. Any of those sheets I named XXREC – XX is a number (01REC, 02REC, 03REC,… 50REC). I need to create a Workbook for each worksheet, rename the workbook with the actual name (I mean, number) of the sheet without the 3 last letters (REC) and rename the sheet inside the workbook, with Sheet1.

Until now, checking other examples, I create this:

Sub CreateBooks()
    Workbooks.Open Filename:="C:\exp1.xls"
Dim w As Worksheet
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
        For Each w In ActiveWorkbook.Worksheets
            w.Copy
                ActiveWorkbook.SaveAs Filename:="C:\Exp\" & w.Name
                    ActiveWorkbook.Close
    Next w
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
                    ActiveWorkbook.Close
End Sub

Thank you in advance for any help

Please wrap code next time


Try this:

Sub CreateBooks()

Dim wb1 As Workbook
Dim wb2 As Workbook
Dim sht As Worksheet
Dim sht2 As Worksheet
Dim fPath As String

Workbooks.Open fileName:="C:\exp1.xls"

Set wb1 = ActiveWorkbook

fPath = Left(wb1.FullName, Application.WorksheetFunction.Find(wb1.Name, wb1.FullName) - 1)

Application.ScreenUpdating = False
Application.DisplayAlerts = False

For Each sht In wb1.Sheets
    Workbooks.Add
    Set wb2 = ActiveWorkbook
    sht.Copy Before:=wb2.Sheets(1)
    For Each sht2 In wb2.Sheets
        If sht2.Name <> sht.Name Then
            sht2.Delete
        End If
    Next sht2
    wb2.Sheets(sht.Name).Name = "Sheet1"
    wb2.SaveAs fileName:=fPath & Left(sht.Name, Len(sht.Name) - 3)
Next sht

Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

ska

Jokacave,

Here is the code you were using with a few minor modifications and it appears to do what you are wanting it to do on my end.

Sub CreateBooks()

Dim w As Worksheet
Dim sName As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each w In ActiveWorkbook.Worksheets
    w.Copy
    sName = w.Name
    Sheets(sName).Name = "Sheet1"
    ActiveWorkbook.SaveAs Filename:="C:\Exp" & Left(w.Name, 2)
    ActiveWorkbook.Close
Next w
Application.DisplayAlerts = True
Application.ScreenUpdating = True
ActiveWorkbook.Close

End Sub

Jokacave,

Great! I look forward to hearing how both sets of code work. I am sure that both with do what you are wanting. I just wanted to give you something as close to what you had already written as possible.

Where in Asia are you?