none
Splitting files from a single workbook RRS feed

  • Question

  • Hi - I found a great vba code online that helps me split my file exactly the way i need it to (keeping protection, formatting, formulas, headers etc). Credit to mtone for this code. But i also need it to bring over sheet 2 from my master workbook to the new split workbooks as there are tables that it will need to reference as I send out my files. Is there anyway to tweek this code to bring over sheet 2 as well to the new split files?. I have tried everything and is coming up with errors. Help is greatly appreciated!!! 

    Public Sub SplitToFiles()

    ' Loops through a specified column, and split each distinct values into a separate file by making a copy and deleting rows below and above
    '
    ' Note: Values in the column should be unique or sorted.
    '
    ' 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.

    'Active workbook password protection

     Sheets(1).Protect Password:="Secret", _
        UserInterFaceOnly:=True
     
    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
             
             'set split worksheets password protected
              Sheets(1).Protect Password:="Secret", _
        UserInterFaceOnly:=True
        
         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


    Sunday, February 21, 2016 3:38 PM

Answers

  • >>>But i also need it to bring over sheet 2 from my master workbook to the new split workbooks as there are tables that it will need to reference as I send out my files. Is there anyway to tweek this code to bring over sheet 2 as well to the new split files?. I have tried everything and is coming up with errors.

    According to your description, if you want to split a workbook into multiple workbooks, you could refer to below:

    Sub Splitbook()
    
        Dim xPath As String
        xPath = Application.ActiveWorkbook.Path
        Application.ScreenUpdating = False
        Application.DisplayAlerts = False
        For Each xWs In ThisWorkbook.Sheets
          xWs.Copy
          Application.ActiveWorkbook.SaveAs Filename:=xPath & "\" & xWs.Name & ".xls"
          Application.ActiveWorkbook.Close False
        Next
        Application.DisplayAlerts = True
        Application.ScreenUpdating = True
    
    End Sub
    

    In addition could you provide more information about your issue, for example sample file, sample code, error code, screenshot etc., that will help us reproduce and resolve it.

    Thanks for your understanding.

    • Marked as answer by David_JunFeng Thursday, March 3, 2016 7:02 AM
    Monday, February 22, 2016 9:46 AM

All replies

  • >>>But i also need it to bring over sheet 2 from my master workbook to the new split workbooks as there are tables that it will need to reference as I send out my files. Is there anyway to tweek this code to bring over sheet 2 as well to the new split files?. I have tried everything and is coming up with errors.

    According to your description, if you want to split a workbook into multiple workbooks, you could refer to below:

    Sub Splitbook()
    
        Dim xPath As String
        xPath = Application.ActiveWorkbook.Path
        Application.ScreenUpdating = False
        Application.DisplayAlerts = False
        For Each xWs In ThisWorkbook.Sheets
          xWs.Copy
          Application.ActiveWorkbook.SaveAs Filename:=xPath & "\" & xWs.Name & ".xls"
          Application.ActiveWorkbook.Close False
        Next
        Application.DisplayAlerts = True
        Application.ScreenUpdating = True
    
    End Sub
    

    In addition could you provide more information about your issue, for example sample file, sample code, error code, screenshot etc., that will help us reproduce and resolve it.

    Thanks for your understanding.

    • Marked as answer by David_JunFeng Thursday, March 3, 2016 7:02 AM
    Monday, February 22, 2016 9:46 AM
  • Hi David,

    Your reply just gave me a little ounce of hope as I was just going to give up. I'm still new to vba and have only dealt with basic macros, so this is a bit too sophisticated for me right now but I really want to try to apply this for a project I'm going to soon be taking on. I would like to send you my example sample file for a better understanding but as I'm new to the forum, I'm not sure how I can attached the sample file over to you? It doesn't seem to give me that option here........

    <cite></cite>

    Saturday, March 12, 2016 3:32 PM
  • Hi, Albery Louise

    According to your description, I suggest that you could upload your Excel file on OneDrive? we will be glad to help you resolve your issue.

    Thanks for your understanding.
    Monday, March 14, 2016 8:10 AM
  • Hi David,

    I uploaded a SAMPLE FILE :

    https://onedrive.live.com/redir?resid=1FFF53B284175EB6!108&authkey=!ALILEocGyOuAFyY&ithint=file%2cxlsm

    I would like to create a macro to split the file up based on column E while maintaining all the formatting, formulas, links, headers, protection, and total. There is a hidden sheet "STORE" that I use as reference and I would like to bring that along with the new split files which will also be hidden.

    The macro currently does everything I need it to except for bringing over the 2nd sheet and total :(

    Any help is appreciated!!! Thank you in advance!

    Friday, March 18, 2016 2:36 AM
  • Have you got your problem solved? I have similar needs. If you do, could you please share it with me? Thanks. I appreciate!
    Tuesday, October 10, 2017 4:17 PM
  • This code is awesome, but how can it be adjusted so they export as CSV, thanks in advance

    Sunday, February 16, 2020 1:33 PM
  • If you still remember (2017!), did you get this solved?  I am also in need of splitting one Master workbook with two worksheets into multiple files based on values in one of the columns in the worksheets.

    There are no mistakes; every result tells you something of value about what you are trying to accomplish.

    Friday, February 21, 2020 5:21 PM