Consulting

Results 1 to 17 of 17

Thread: Create New Workbook from existing Tab

  1. #1
    VBAX Regular
    Joined
    Nov 2011
    Posts
    34
    Location

    Create New Workbook from existing Tab

    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
    Attached Files Attached Files

  2. #2
    VBAX Guru Kenneth Hobs's Avatar
    Joined
    Nov 2005
    Location
    Tecumseh, OK
    Posts
    4,911
    Location
    [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]

  3. #3
    VBAX Regular
    Joined
    Nov 2011
    Posts
    34
    Location
    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



    Quote Originally Posted by 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]

  4. #4
    VBAX Guru Kenneth Hobs's Avatar
    Joined
    Nov 2005
    Location
    Tecumseh, OK
    Posts
    4,911
    Location
    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]

  5. #5
    VBAX Regular
    Joined
    Nov 2011
    Posts
    34
    Location
    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


    Quote Originally Posted by 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]

  6. #6
    VBAX Guru Kenneth Hobs's Avatar
    Joined
    Nov 2005
    Location
    Tecumseh, OK
    Posts
    4,911
    Location
    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]

  7. #7
    VBAX Regular
    Joined
    Nov 2011
    Posts
    34
    Location
    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
    Attached Files Attached Files

  8. #8
    VBAX Guru Kenneth Hobs's Avatar
    Joined
    Nov 2005
    Location
    Tecumseh, OK
    Posts
    4,911
    Location
    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]

  9. #9
    VBAX Regular
    Joined
    Nov 2011
    Posts
    34
    Location
    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.

  10. #10
    VBAX Guru Kenneth Hobs's Avatar
    Joined
    Nov 2005
    Location
    Tecumseh, OK
    Posts
    4,911
    Location
    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.

  11. #11
    VBAX Regular
    Joined
    Nov 2011
    Posts
    34
    Location
    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.

  12. #12
    VBAX Regular
    Joined
    Nov 2011
    Posts
    34
    Location
    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

  13. #13
    VBAX Guru Kenneth Hobs's Avatar
    Joined
    Nov 2005
    Location
    Tecumseh, OK
    Posts
    4,911
    Location
    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]

  14. #14
    VBAX Regular
    Joined
    Nov 2011
    Posts
    34
    Location
    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

  15. #15
    VBAX Guru Kenneth Hobs's Avatar
    Joined
    Nov 2005
    Location
    Tecumseh, OK
    Posts
    4,911
    Location
    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]

  16. #16
    VBAX Regular
    Joined
    Nov 2011
    Posts
    34
    Location
    Thank You Sir....

  17. #17

    Its really helpful

    Its really helpfull. Thanks

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •