none
Need to split excel (2016) worksheet based on column in 1st tab and then copy over remaining tabs to each new workbook as well RRS feed

  • Question

  • So I've been using the following code to split a worksheet into multiple workbooks, based on one unique column in Tab 1. However, I have an urgent need to now also copy over the additional tabs in the workbook (Tab 2, 3, and 4). The additional tabs do not have anything unique about them, they just need to be copied over with the first tab for each of the newly created split workbooks. Note: need to copy in a way that formulas would still be embedded in those additional tabs. Can you help me? I cannot figure out how to add that portion (bringing over tabs 2,3, and 4) along with tab 1 in the new split files.  Thanks!!

    Code:

    ' MACRO SplitFilesMacro
    '
    'Description:
    ' Goes through the specified column and splits each unique values into separate files by making a copy and deleting rows below and above
    '
    ' The following cells are ignored when delimiting sections:
    ' - blank cells, or containing spaces only
    ' - same value repeated
    ' - cells containing "total"
    '
    ' Files are saved in a "Split" subfolder from the location of the source workbook, and named after the section name.

    Dim osh As Worksheet ' Original sheet
    Dim iRow As Long ' Cursors
    Dim iCol As Long
    Dim iFirstRow As Long ' Constant
    Dim iTotalRows As Long ' Constant
    Dim iStartRow As Long ' Section delimiters
    Dim iStopRow As Long
    Dim sSectionName As String ' Section name (and filename)
    Dim rCell As Range ' current cell
    Dim owb As Workbook ' Original workbook
    Dim sFilePath As String ' Constant
    Dim iCount As Integer ' # of documents created

    iCol = Application.InputBox("Enter the column number used for splitting", "Select column", 2, , , , , 1)
    iRow = Application.InputBox("Enter the starting row number (to skip header)", "Select row", 5, , , , , 1)
    iFirstRow = iRow

    Set osh = Application.ActiveSheet
    Set owb = Application.ActiveWorkbook
    iTotalRows = osh.UsedRange.Rows.Count
    sFilePath = Application.ActiveWorkbook.Path

    If Dir(sFilePath + "\Split", vbDirectory) = "" Then
        MkDir sFilePath + "\Split"
    End If

    'Turn Off Screen Updating  Events
    Application.EnableEvents = False
    Application.ScreenUpdating = False

    Do
        ' Get cell at cursor
        Set rCell = osh.Cells(iRow, iCol)
        sCell = Replace(rCell.Text, " ", "")

        If sCell = "" Or (rCell.Text = sSectionName And iStartRow <> 0) Or InStr(1, rCell.Text, "total", vbTextCompare) <> 0 Then
            ' Skip condition met
        Else
            ' Found new section
            If iStartRow = 0 Then
                ' StartRow delimiter not set, meaning beginning a new section
                sSectionName = rCell.Text
                iStartRow = iRow
            Else
                ' StartRow delimiter set, meaning we reached the end of a section
                iStopRow = iRow - 1

                ' Pass variables to a separate sub to create and save the new worksheet
                CopySheet osh, iFirstRow, iStartRow, iStopRow, iTotalRows, sFilePath, sSectionName, owb.fileFormat
                iCount = iCount + 1

                ' Reset section delimiters
                iStartRow = 0
                iStopRow = 0

                ' Ready to continue loop
                iRow = iRow - 1
            End If
        End If

        ' Continue until last row is reached
        If iRow < iTotalRows Then
                iRow = iRow + 1
        Else
            ' Finished. Save the last section
            iStopRow = iRow
            CopySheet osh, iFirstRow, iStartRow, iStopRow, iTotalRows, sFilePath, sSectionName, owb.fileFormat
            iCount = iCount + 1

            ' Exit
            Exit Do
        End If
    Loop

    'Turn On Screen Updating  Events
    Application.ScreenUpdating = True
    Application.EnableEvents = True

    MsgBox Str(iCount) + " documents saved in " + sFilePath


    End Sub

    Public Sub DeleteRows(targetSheet As Worksheet, RowFrom As Long, RowTo As Long)

    Dim rngRange As Range
    Set rngRange = Range(targetSheet.Cells(RowFrom, 1), targetSheet.Cells(RowTo, 1)).EntireRow
    rngRange.Select
    rngRange.Delete

    End Sub


    Public Sub CopySheet(osh As Worksheet, iFirstRow As Long, iStartRow As Long, iStopRow As Long, iTotalRows As Long, sFilePath As String, sSectionName As String, fileFormat As XlFileFormat)
         Dim ash As Worksheet ' Copied sheet
         Dim awb As Workbook ' New workbook

         ' Copy book
         osh.Copy
         Set ash = Application.ActiveSheet

         ' Delete Rows after section
         If iTotalRows > iStopRow Then
             DeleteRows ash, iStopRow + 1, iTotalRows
         End If

         ' Delete Rows before section
         If iStartRow > iFirstRow Then
             DeleteRows ash, iFirstRow, iStartRow - 1
         End If

         ' Select left-topmost cell
         ash.Cells(1, 1).Select

         ' Clean up a few characters to prevent invalid filename
         sSectionName = Replace(sSectionName, "/", " ")
         sSectionName = Replace(sSectionName, "\", " ")
         sSectionName = Replace(sSectionName, ":", " ")
         sSectionName = Replace(sSectionName, "=", " ")
         sSectionName = Replace(sSectionName, "*", " ")
         sSectionName = Replace(sSectionName, ".", " ")
         sSectionName = Replace(sSectionName, "?", " ")

         ' Save in same format as original workbook
         ash.SaveAs sFilePath + "\Split\" + sSectionName, fileFormat

         ' Close
         Set awb = ash.Parent
         awb.Close SaveChanges:=False
    End Sub

    Wednesday, October 9, 2019 10:15 PM

Answers

  • Below the line

        Set ash = Application.ActiveSheet

    in the CopySheet procedure, insert the following:

        ' *** Copy other sheets ***
        osh.Parent.Worksheets(Array(2, 3, 4)).Copy After:=ash


    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    • Marked as answer by Jess04m Thursday, October 10, 2019 2:58 PM
    Thursday, October 10, 2019 11:54 AM
  • Replace the lines

    rngRange.Select
    rngRange.Delete

    with

    rngRange.Delete


    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    • Marked as answer by Jess04m Thursday, October 10, 2019 2:57 PM
    Thursday, October 10, 2019 1:49 PM
  • Worksheets(Array(2, 3, 4)) refers to the 2nd, 3rd and 4th worksheets (counting from left to right), regardless of their names.

    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    • Marked as answer by Jess04m Thursday, October 10, 2019 2:58 PM
    Thursday, October 10, 2019 1:50 PM

All replies

  • Below the line

        Set ash = Application.ActiveSheet

    in the CopySheet procedure, insert the following:

        ' *** Copy other sheets ***
        osh.Parent.Worksheets(Array(2, 3, 4)).Copy After:=ash


    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    • Marked as answer by Jess04m Thursday, October 10, 2019 2:58 PM
    Thursday, October 10, 2019 11:54 AM
  • Does "2,3,4" equal the names of the other tabs? So if its actually called something else, I would need to enter that name instead, correct? So for this work, the 2nd tab is actually titled "model"
    Thursday, October 10, 2019 1:08 PM
  • It looks like there is a problem, so after I add your piece, it now comes up with a "Run-time error '1004' Select method of Range class failed, and points to the "rngRange.Select" part of the code as the issue.

    Here is the updated code, with your addition, did I put in in the wrong place?

    Dim osh As Worksheet ' Original sheet
    Dim iRow As Long ' Cursors
    Dim iCol As Long
    Dim iFirstRow As Long ' Constant
    Dim iTotalRows As Long ' Constant
    Dim iStartRow As Long ' Section delimiters
    Dim iStopRow As Long
    Dim sSectionName As String ' Section name (and filename)
    Dim rCell As Range ' current cell
    Dim owb As Workbook ' Original workbook
    Dim sFilePath As String ' Constant
    Dim iCount As Integer ' # of documents created

    iCol = Application.InputBox("Enter the column number used for splitting", "Select column", 2, , , , , 1)
    iRow = Application.InputBox("Enter the starting row number (to skip header)", "Select row", 5, , , , , 1)
    iFirstRow = iRow

    Set osh = Application.ActiveSheet
    Set owb = Application.ActiveWorkbook
    iTotalRows = osh.UsedRange.Rows.Count
    sFilePath = Application.ActiveWorkbook.Path

    If Dir(sFilePath + "\Split", vbDirectory) = "" Then
        MkDir sFilePath + "\Split"
    End If

    'Turn Off Screen Updating  Events
    Application.EnableEvents = False
    Application.ScreenUpdating = False

    Do
        ' Get cell at cursor
        Set rCell = osh.Cells(iRow, iCol)
        sCell = Replace(rCell.Text, " ", "")

        If sCell = "" Or (rCell.Text = sSectionName And iStartRow <> 0) Or InStr(1, rCell.Text, "total", vbTextCompare) <> 0 Then
            ' Skip condition met
        Else
            ' Found new section
            If iStartRow = 0 Then
                ' StartRow delimiter not set, meaning beginning a new section
                sSectionName = rCell.Text
                iStartRow = iRow
            Else
                ' StartRow delimiter set, meaning we reached the end of a section
                iStopRow = iRow - 1

                ' Pass variables to a separate sub to create and save the new worksheet
                CopySheet osh, iFirstRow, iStartRow, iStopRow, iTotalRows, sFilePath, sSectionName, owb.fileFormat
                iCount = iCount + 1

                ' Reset section delimiters
                iStartRow = 0
                iStopRow = 0

                ' Ready to continue loop
                iRow = iRow - 1
            End If
        End If

        ' Continue until last row is reached
        If iRow < iTotalRows Then
                iRow = iRow + 1
        Else
            ' Finished. Save the last section
            iStopRow = iRow
            CopySheet osh, iFirstRow, iStartRow, iStopRow, iTotalRows, sFilePath, sSectionName, owb.fileFormat
            iCount = iCount + 1

            ' Exit
            Exit Do
        End If
    Loop

    'Turn On Screen Updating  Events
    Application.ScreenUpdating = True
    Application.EnableEvents = True

    MsgBox Str(iCount) + " documents saved in " + sFilePath


    End Sub

    Public Sub DeleteRows(targetSheet As Worksheet, RowFrom As Long, RowTo As Long)

    Dim rngRange As Range
    Set rngRange = Range(targetSheet.Cells(RowFrom, 1), targetSheet.Cells(RowTo, 1)).EntireRow
    rngRange.Select
    rngRange.Delete

    End Sub


    Public Sub CopySheet(osh As Worksheet, iFirstRow As Long, iStartRow As Long, iStopRow As Long, iTotalRows As Long, sFilePath As String, sSectionName As String, fileFormat As XlFileFormat)
         Dim ash As Worksheet ' Copied sheet
         Dim awb As Workbook ' New workbook

         ' Copy book
         osh.Copy
         Set ash = Application.ActiveSheet
         osh.Parent.Worksheets(Array("Single TM Worksheet")).Copy After:=ash

         ' Delete Rows after section
         If iTotalRows > iStopRow Then
             DeleteRows ash, iStopRow + 1, iTotalRows
         End If

         ' Delete Rows before section
         If iStartRow > iFirstRow Then
             DeleteRows ash, iFirstRow, iStartRow - 1
         End If

         ' Select left-topmost cell
         ash.Cells(1, 1).Select

         ' Clean up a few characters to prevent invalid filename
         sSectionName = Replace(sSectionName, "/", " ")
         sSectionName = Replace(sSectionName, "\", " ")
         sSectionName = Replace(sSectionName, ":", " ")
         sSectionName = Replace(sSectionName, "=", " ")
         sSectionName = Replace(sSectionName, "*", " ")
         sSectionName = Replace(sSectionName, ".", " ")
         sSectionName = Replace(sSectionName, "?", " ")

         ' Save in same format as original workbook
         ash.SaveAs sFilePath + "\Split\" + sSectionName, fileFormat

         ' Close
         Set awb = ash.Parent
         awb.Close SaveChanges:=False
    End Sub

    • Edited by Jess04m Thursday, October 10, 2019 1:38 PM
    Thursday, October 10, 2019 1:26 PM
  • Replace the lines

    rngRange.Select
    rngRange.Delete

    with

    rngRange.Delete


    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    • Marked as answer by Jess04m Thursday, October 10, 2019 2:57 PM
    Thursday, October 10, 2019 1:49 PM
  • Worksheets(Array(2, 3, 4)) refers to the 2nd, 3rd and 4th worksheets (counting from left to right), regardless of their names.

    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    • Marked as answer by Jess04m Thursday, October 10, 2019 2:58 PM
    Thursday, October 10, 2019 1:50 PM
  • Hey,

    So when it copies them over, it holds onto the previous file name in the formulas.  How do I make it completely disconnect from the original file, so that it doesn't keep pointing back to the original file in the formulas.

    Thanks for all of your help!

    Thursday, October 10, 2019 2:32 PM
  • Is this just in the first sheet that has been copied, or in all copied sheets?

    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    Thursday, October 10, 2019 3:05 PM
  • Its actually just the first 2 sheets. Sheet 1 is named "Model" and Sheet 2 is named "Single TM Worksheet". The other tabs don't have any formulas in them, just those first two tabs mentioned above.
    Thursday, October 10, 2019 3:28 PM
  • Below the lines

        ' Select left-topmost cell
         ash.Cells(1, 1).Select

    insert

        Dim wsh As Worksheet
        For Each wsh In ash.Parent.Worksheets
            With wsh.UsedRange
                .Value = .Value
            End With
        Next wsh


    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    Thursday, October 10, 2019 3:34 PM
  • It looks like that actually just completely removed the formula. I wanted to leave in the formula, but have it only reference the workbook that the formula is now in, as opposed to the original workbook.

    Thanks,

    Jessica

    Thursday, October 10, 2019 3:54 PM
  • Whether the following will work depends on the structure of the workbook, so test carefully.

    Instead of the code from my previous reply, use

        Dim wsh As Worksheet
        For Each wsh In ash.Parent.Worksheets
            wsh.UsedRange.Replace What:="[*]", Replacement:="", LookAt:=xlPart
        Next wsh


    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    Thursday, October 10, 2019 6:45 PM
  • That did it! Last but not least, how can I add a password protect to the overall document as well as the worksheets (so that they cannot unhide certain tabs). 

    And again thank you SO MUCH!

    Thursday, October 10, 2019 7:47 PM
  • If you really want to protect the sheets (so that they cannot be modified in any way, change

        Dim wsh As Worksheet
        For Each wsh In ash.Parent.Worksheets
            wsh.UsedRange.Replace What:="[*]", Replacement:="", LookAt:=xlPart
        Next wsh

    to

        Dim wsh As Worksheet
        For Each wsh In ash.Parent.Worksheets
            wsh.UsedRange.Replace What:="[*]", Replacement:="", LookAt:=xlPart
            wsh.Protect Password:="Secret"
        Next wsh

    To protect the structure of the workbook, insert the following above the SaveAs line:

        ash.Parent.Protect Password:="Secret", Structure:=True


    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    Thursday, October 10, 2019 7:56 PM