Create New Workbook from existing Tab

[NM123]

Hi All,

I want to create new workbooks from an excel sheet which is having more than 1 sheet. Through VBA i want to create each new work sheet and save as local file where the Parent file is saved.

I have attached an excel sheet for example and understanding along with the partial code. The sheet contains more than 1 tab named as Case-1,Case-2 etc.... I want each tab of the sheet to stored as independent Workbook rather than in the Tabs.

i need this very urgently. Please let me know if you need any other information.

Regards,
NM123

[Kenneth Hobs]

[VBA]Sub CaseSheetsAsWorkbooks()
Dim ws As Worksheet, destFolder As String
destFolder = ThisWorkbook.Path & "\"
For Each ws In Worksheets
If Left(ws.Name, 4) = "Case" Then
With ws
.SaveAs destFolder & .Name
End With
End If
Next ws
End Sub[/VBA]

[NM123]

Hi Kenneth,
Thanks for your response. I have excuted the code snippet that you have provided, but is not helping me completely. I mean it is saving the worksheet file as per the sheet name. But it is also containing the other worksheets, which i dont want and it should save as the independent Workbook only i.e no other sheet it should have. Below is the code snippet to change the File name from Case-1(e.g.) to new Workbook.

strFileName = Sheets(shtSheetName.Name).Range("B2").Value & "_" & Sheets(shtSheetName.Name).Range("B3")
strFilePath = strFilePath & "\" & strFileName

Waiting for your response.
Regards,
NM123

[vba]Sub CaseSheetsAsWorkbooks()
Dim ws As Worksheet, destFolder As String
destFolder = ThisWorkbook.Path & "\"
For Each ws In Worksheets
If Left(ws.Name, 4) = "Case" Then
With ws
.SaveAs destFolder & .Name
End With
End If
Next ws
End Sub[/vba]

[Kenneth Hobs]

Sorry, I did not check the output as I usually do. This can be made faster using some other methods but this is easy to understand. If your filename has illegal characters, it will fail. Some of that can be checked if needed.

[vba]Option Explicit
Sub CaseSheetsAsWorkbooks()
Dim ws As Worksheet, destFolder As String
Dim wb As Workbook, wbs As Worksheet, wbName As String
destFolder = ThisWorkbook.Path & "\"
With Application
.EnableEvents = False
.DisplayAlerts = False
.ScreenUpdating = False
End With

For Each ws In Worksheets
If Left(ws.Name, 4) = "Case" Then
With ws
wbName = destFolder & .Range("B2").Value2 & "_" & .Range("B3").Value2 & ".xlsx"
If Dir(wbName) <> "" Then Kill (wbName)
Set wb = Workbooks.Add
.Copy wb.Worksheets(1)
For Each wbs In wb.Sheets
If wbs.Name <> .Name Then wbs.Delete
Next wbs
wb.Close True, wbName
End With
End If
Next ws

With Application
.EnableEvents = True
.DisplayAlerts = True
.ScreenUpdating = True
End With
End Sub
[/vba]

[NM123]

Thanks a lot Sir,
It really helped me !!!

1 more thing i how can i rename the Sheet Name( For e.g. Sheet1) after it converts to New Workbook.

regards,
NM123

Sorry, I did not check the output as I usually do. This can be made faster using some other methods but this is easy to understand. If your filename has illegal characters, it will fail. Some of that can be checked if needed.

[vba]Option Explicit

Sub CaseSheetsAsWorkbooks()
Dim ws As Worksheet, destFolder As String
Dim wb As Workbook, wbs As Worksheet, wbName As String

destFolder = ThisWorkbook.Path & "\"

With Application
.EnableEvents = False
.DisplayAlerts = False
.ScreenUpdating = False
End With

For Each ws In Worksheets
If Left(ws.Name, 4) = "Case" Then
With ws
wbName = destFolder & .Range("B2").Value2 & "_" & .Range("B3").Value2 & ".xlsx"
If Dir(wbName) <> "" Then Kill (wbName)
Set wb = Workbooks.Add
.Copy wb.Worksheets(1)
For Each wbs In wb.Sheets
If wbs.Name <> .Name Then wbs.Delete
Next wbs
wb.Close True, wbName
End With
End If
Next ws

With Application
.EnableEvents = True
.DisplayAlerts = True
.ScreenUpdating = True
End With
End Sub

[/vba]

[Kenneth Hobs]

Please do not quote and thereby repeat a whole post or a whole code unless you really need to.

Before the wb.close line:
[VBA] wb.Worksheets(1).Name = Format(Date, "mm-dd-yyyy")[/VBA]

[NM123]

Hello Sir,

Thanks for your inputs. It worked for smaller volume. But when Workbook is having more number(for e.g.30 odd) of worksheet, then it is throwing error "File not Found" in the below code.

If Dir(wbName) <> "" Then Kill (wbName).

Not sure why it happenning. Can you please put some light on this.

Attached is the file for your references.

Regards,
NM123

[Kenneth Hobs]

I just added one word to insure that the sheets it iterated were from the master workbook, ThisWorkbook.

[VBA]Sub CaseSheetsAsWorkbooks()
Dim ws As Worksheet, destFolder As String
Dim wb As Workbook, wbs As Worksheet, wbName As String

destFolder = ThisWorkbook.Path & "\"

With Application
.EnableEvents = False
.DisplayAlerts = False
.ScreenUpdating = False
End With

For Each ws In ThisWorkbook.Worksheets
If Left(ws.Name, 4) = "Case" Then
With ws
wbName = destFolder & .Range("B2").Value2 & "_" & .Range("B3").Value2 & ".xlsx"
If Dir(wbName) <> "" Then Kill (wbName)
Set wb = Workbooks.Add
.Copy wb.Worksheets(1)
For Each wbs In wb.Sheets
If wbs.Name <> .Name Then wbs.Delete
Next wbs
wb.Worksheets(1).Name = Format(Date, "mm-dd-yyyy")
wb.Close True, wbName
End With
End If
Next ws

With Application
.EnableEvents = True
.DisplayAlerts = True
.ScreenUpdating = True
End With
End Sub[/VBA]

[NM123]

Dear Sir,
i am still getting the same error i.e. "File not Found", Path Not Correct etc..
So its not working Sir. Please help me to complete this.

Sir,
for small worksheets, once It becomes new Workbook, The new Excel workbook sometimes doesnt open.it gets corrupt also.Then i have re-run the code again to generate the New workbooks. Any solution for this.

[Kenneth Hobs]

Working from your last post with my last solution I can not duplicate your problem. As I explained before, if you have built an illegal filename, it can not be saved. Try simplifying the filename:
[vba] wbName = destFolder & .Range("B2").Value2[/vba]

IF you have not saved the master workbook with the macro, Thisworbook.Path will not exist. Change it to your path if you want something other than that but be sure to add the trailing backslash.

[NM123]

Sir,

Each worksheet is having Test Number i.e.B2 and the Test Description i.e. B3. I want to have concatenate both to name as the file name or New Workbook name. I am saving the file as per the below mentioned structure and need all the new workbook to be saved there as per the module.

For e.g. The file will be like this as follows:

ST.01.04.001_OB and Crew Passes Departure Test_crew already logged on_OB Initializing state.

Where ST.01.04.001 is the B2 value and the B3 value is The description mentioned as above.

[NM123]

Sir,
I just did some analysis after your post and found that while saving the file, if it is having any of the following charcters < > ? [ ] : | *. then it will throw error.

As in my sheet B3(Test Name) is having Period(.) at last. Because of this it was throwing error.
How can i remove the Period(.) before saving if any file is having the period at the end. Some files do have the period(.) and some doesnt have.

Need some inputs...


Regards,
NM

[Kenneth Hobs]

This may not find all the bad characters but should strip many.

[VBA]Sub LegalFilename()
Dim s As String
s = "//\\<<>>:""""|*?ken.txt//\\<<>>:""""|*?"
MsgBox s & "= " & StripIllegalChars(s)
End Sub


Function StripIllegalChars(baseFN As String) As String
Dim bad(1 To 10) As Variant, s As String, c As String
Dim v As Variant, i As Variant

bad(1) = "/"
bad(2) = "\"
bad(3) = "<"
bad(4) = ">"
bad(5) = ":"
bad(6) = vbNullString
bad(7) = """"
bad(8) = "|"
bad(9) = "*"
bad(10) = "?"

s = baseFN
For i = 1 To Len(baseFN)
c = Mid(baseFN, i, 1)
If (Asc(c) >= 1 And Asc(c) <= 31) Or Index(bad, c) <> -1 Then
s = Replace(s, c, "")
End If
Next i
StripIllegalChars = s
End Function

'val is not case sensitive
Function Index(vArray() As Variant, val As Variant) As Long
On Error GoTo Minus1
Index = WorksheetFunction.Match(val, WorksheetFunction.Transpose(vArray), 0)
Exit Function
Minus1:
Index = -1
End Function
[/VBA]

[NM123]

Hello Sir,

Thanks for your inputs....

Just wondering when should i use this fucntion. I mean after creating the New workbook(as per the code you have posted earlier) or before creating the New workbook.

Regards,
NM

[Kenneth Hobs]

Use it where the filename is built by the two cells.

[VBA]Sub CaseSheetsAsWorkbooks()
Dim ws As Worksheet, destFolder As String
Dim wb As Workbook, wbs As Worksheet, wbName As String

destFolder = ThisWorkbook.Path & "\"

With Application
.EnableEvents = False
.DisplayAlerts = False
.ScreenUpdating = False
End With

For Each ws In ThisWorkbook.Worksheets
If Left(ws.Name, 4) = "Case" Then
With ws
wbName = destFolder & StripIllegalChars(.Range("B2").Value2 & "_" & .Range("B3").Value2 & ".xlsx")
If Dir(wbName) <> "" Then Kill (wbName)
Set wb = Workbooks.Add
.Copy wb.Worksheets(1)
For Each wbs In wb.Sheets
If wbs.Name <> .Name Then wbs.Delete
Next wbs
wb.Worksheets(1).Name = Format(Date, "mm-dd-yyyy")
wb.Close True, wbName
End With
End If
Next ws

With Application
.EnableEvents = True
.DisplayAlerts = True
.ScreenUpdating = True
End With
End Sub

Function StripIllegalChars(baseFN As String) As String
Dim bad(1 To 10) As Variant, s As String, c As String
Dim v As Variant, i As Variant

bad(1) = "/"
bad(2) = "\"
bad(3) = "<"
bad(4) = ">"
bad(5) = ":"
bad(6) = vbNullString
bad(7) = """"
bad(8) = "|"
bad(9) = "*"
bad(10) = "?"

s = baseFN
For i = 1 To Len(baseFN)
c = Mid(baseFN, i, 1)
If (Asc(c) >= 1 And Asc(c) <= 31) Or Index(bad, c) <> -1 Then
s = Replace(s, c, "")
End If
Next i
StripIllegalChars = s
End Function

'val is not case sensitive
Function Index(vArray() As Variant, val As Variant) As Long
On Error GoTo Minus1
Index = WorksheetFunction.Match(val, WorksheetFunction.Transpose(vArray), 0)
Exit Function
Minus1:
Index = -1
End Function
[/VBA]

[NM123]

Thank You Sir....

[aleenkhan]

Its really helpfull. Thanks