none
VBA Macro to split a workbook with 3 worksheets into multiple workbooks with multiple worksheets (3 in this case) based on a column RRS feed

  • Question

  • Hello

    Can anyone help me with a macro that can split a workbook with 3 sheets into multiple workbooks with multiple worksheets based on a column?

    I have managed to split for the firs sheet of the master workbook into multiple files, but when i get to the second one i have a message saying that a file with the name X already exists. If a file already exists the macro should be able to add a new sheet to the existing file with the info and so on

    The macro that i've used is this one:

    Option Explicit
    Sub ParseItems()
    Dim LR1 As Long, LR2 As Long, LR3 As Long, Itm1 As Long, Itm2 As Long, Itm3 As Long, MyCount1 As Long, MyCount2 As Long, MyCount3   As Long, vCol1 As Long, vCol2 As Long, vCol3 As Long
    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet, MyArr1 As Variant, MyArr2 As Variant, MyArr3 As Variant, vTitles1 As String, vTitles2 As String, vTitles3 As String, SvPath As String, MyStr As String
    'Sheet with data in it
    Set ws1 = Sheets("Sheet1")
    Set ws2 = Sheets("Sheet2")
    Set ws3 = Sheets("Sheet3")

    'Path to save files into, remember the final \
    SvPath = "D:\X\"

    'Range where titles are across top of data, as string, data MUST
    'have titles in this row, edit to suit your titles locale
    vTitles1 = "A1:DL1"
    'Choose column to evaluate from, column A = 1, B = 2, etc.
    vCol1 = Application.InputBox("What column to split data by? " & vbLf _
    & vbLf & "(CODE=1)", "Which column?", 1, Type:=1)
    If vCol1 = 0 Then Exit Sub
    'Spot bottom row of data
    LR1 = ws1.Cells(ws1.Rows.Count, vCol1).End(xlUp).Row
    'Speed up macro execution
     Application.ScreenUpdating = False
    'Get a temporary list of unique values from key column
    ws1.Columns(vCol1).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ws1.Range("EE1"), Unique:=True
    'Sort the temporary list
    ws1.Columns("EE:EE").Sort Key1:=ws1.Range("EE2"), Order1:=xlAscending, Header:=xlYes, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
    'Put list into an array for looping (values cannot be the result of formulas, must be constants)
    MyArr1 = Application.WorksheetFunction.Transpose(ws1.Range("EE2:EE" & Rows.Count).SpecialCells(xlCellTypeConstants))
    'clear temporary worksheet list
    ws1.Range("EE:EE").Clear
    'Turn on the autofilter, one column only is all that is needed
    ws1.Range(vTitles1).AutoFilter
    'Loop through list one value at a time
    For Itm1 = 1 To UBound(MyArr1)
    ws1.Range(vTitles1).AutoFilter Field:=vCol1, Criteria1:=MyArr1(Itm1)
    ws1.Range("A1:A" & LR1).EntireRow.Copy
    Workbooks.Add
    Range("A1").PasteSpecial xlPasteAll
    Cells.Columns.AutoFit
    MyCount1 = MyCount1 + Range("A" & Rows.Count).End(xlUp).Row - 1
    ActiveWorkbook.SaveAs SvPath & MyArr1(Itm1) & Format(Date, " MM-DD-YY") & ".xlsx", 51
    ActiveWorkbook.Close False
    ws1.Range(vTitles1).AutoFilter Field:=vCol1
    Next Itm1
    'Cleanup
    ws1.AutoFilterMode = False
    MsgBox "Rows with data: " & (LR1 - 1) & vbLf & "Rows copied to other sheets: " & MyCount1 & vbLf & "Finalizare split!"
    Application.ScreenUpdating = True


    'Range where titles are across top of data, as string, data MUST
    'have titles in this row, edit to suit your titles locale
    vTitles2 = "A1:T1"
    'Choose column to evaluate from, column A = 1, B = 2, etc.
    vCol2 = Application.InputBox("What column to split data by? " & vbLf _
    & vbLf & "(CODE=1)", "Which column?", 1, Type:=1)
    If vCol2 = 0 Then Exit Sub
    'Spot bottom row of data
    LR2 = ws2.Cells(ws2.Rows.Count, vCol2).End(xlUp).Row
    'Speed up macro execution
     Application.ScreenUpdating = False
    'Get a temporary list of unique values from key column
    ws2.Columns(vCol2).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ws2.Range("EE1"), Unique:=True
    'Sort the temporary list
    ws2.Columns("EE:EE").Sort Key1:=ws2.Range("EE2"), Order1:=xlAscending, Header:=xlYes, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
    'Put list into an array for looping (values cannot be the result of formulas, must be constants)
    MyArr2 = Application.WorksheetFunction.Transpose(ws2.Range("EE2:EE" & Rows.Count).SpecialCells(xlCellTypeConstants))
    'clear temporary worksheet list
    ws2.Range("EE:EE").Clear
    'Turn on the autofilter, one column only is all that is needed
    ws2.Range(vTitles2).AutoFilter
    'Loop through list one value at a time
    For Itm2 = 1 To UBound(MyArr2)
    ws2.Range(vTitles2).AutoFilter Field:=vCol2, Criteria1:=MyArr2(Itm2)
    ws2.Range("A1:A" & LR2).EntireRow.Copy
    'check if filename already exists. if not create a new file
    'if exists create an additional sheet in the existing file

    Workbooks.Add
    Range("A2").PasteSpecial xlPasteAll
    Cells.Columns.AutoFit
    MyCount2 = MyCount2 + Range("A" & Rows.Count).End(xlUp).Row - 1
    ActiveWorkbook.SaveAs SvPath & MyArr2(Itm2) & Format(Date, " MM-DD-YY") & ".xlsx", 51
    ActiveWorkbook.Close False
    ws2.Range(vTitles2).AutoFilter Field:=vCol2
    Next Itm2
    'Cleanup
    ws2.AutoFilterMode = False
    MsgBox "Rows with data: " & (LR2 - 1) & vbLf & "Rows copied to other sheets: " & MyCount2 & vbLf & "Finalizare split!"
    Application.ScreenUpdating = True

    'Range where titles are across top of data, as string, data MUST
    'have titles in this row, edit to suit your titles locale
    vTitles3 = "A1:AC1"
    'Choose column to evaluate from, column A = 1, B = 2, etc.
    vCol3 = Application.InputBox("What column to split data by? " & vbLf _
    & vbLf & "(CODE=1)", "Which column?", 1, Type:=1)
    If vCol3 = 0 Then Exit Sub
    'Spot bottom row of data
    LR3 = ws3.Cells(ws3.Rows.Count, vCol3).End(xlUp).Row
    'Speed up macro execution
    Application.ScreenUpdating = False
    'Get a temporary list of unique values from key column
    ws3.Columns(vCol3).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ws3.Range("EE1"), Unique:=True
    'Sort the temporary list
    ws3.Columns("EE:EE").Sort Key1:=ws3.Range("EE2"), Order1:=xlAscending, Header:=xlYes, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
    'Put list into an array for looping (values cannot be the result of formulas, must be constants)
    MyArr3 = Application.WorksheetFunction.Transpose(ws3.Range("EE2:EE" & Rows.Count).SpecialCells(xlCellTypeConstants))
    'clear temporary worksheet list
    ws3.Range("EE:EE").Clear
    'Turn on the autofilter, one column only is all that is needed
    ws3.Range(vTitles3).AutoFilter
    'Loop through list one value at a time
    For Itm3 = 1 To UBound(MyArr3)
    ws3.Range(vTitles3).AutoFilter Field:=vCol3, Criteria1:=MyArr3(Itm3)
    ws3.Range("A1:A" & LR3).EntireRow.Copy
    Workbooks.Add
    Range("A3").PasteSpecial xlPasteAll
    Cells.Columns.AutoFit
    MyCount3 = MyCount3 + Range("A" & Rows.Count).End(xlUp).Row - 1
    ActiveWorkbook.SaveAs SvPath & MyArr3(Itm3) & Format(Date, " MM-DD-YY") & ".xlsx", 51
    ActiveWorkbook.Close False
    ws3.Range(vTitles3).AutoFilter Field:=vCol3
    Next Itm3
    'Cleanup
    ws3.AutoFilterMode = False
    MsgBox "Rows with data: " & (LR3 - 1) & vbLf & "Rows copied to other sheets: " & MyCount3 & vbLf & "Finalizare split!"
    Application.ScreenUpdating = True


    End Sub

    Wednesday, September 2, 2015 3:08 PM

All replies

  • I looked at your code and immediately thought "don't have time to get to grips with this". You need to make your code more readable. For example instead of:

    'Turn on the autofilter, one column only is all that is needed
    ws1.Range(vTitles1).AutoFilter
    'Loop through list one value at a time
    For Itm1 = 1 To UBound(MyArr1)
    ws1.Range(vTitles1).AutoFilter Field:=vCol1, Criteria1:=MyArr1(Itm1)
    ws1.Range("A1:A" & LR1).EntireRow.Copy
    Workbooks.Add
    Range("A1").PasteSpecial xlPasteAll
    Cells.Columns.AutoFit
    MyCount1 = MyCount1 + Range("A" & Rows.Count).End(xlUp).Row - 1
    ActiveWorkbook.SaveAs SvPath & MyArr1(Itm1) & Format(Date, " MM-DD-YY") & ".xlsx", 51
    ActiveWorkbook.Close False
    ws1.Range(vTitles1).AutoFilter Field:=vCol1
    Next Itm1
    'Cleanup

    use:

    'Turn on the autofilter, one column only is all that is needed
        ws1.Range(vTitles1).AutoFilter
    
    'Loop through list one value at a time
        For Itm1 = 1 To UBound(MyArr1)
            ws1.Range(vTitles1).AutoFilter Field:=vCol1, Criteria1:=MyArr1(Itm1)
            ws1.Range("A1:A" & LR1).EntireRow.Copy
            Workbooks.Add
            Range("A1").PasteSpecial xlPasteAll
            Cells.Columns.AutoFit
            MyCount1 = MyCount1 + Range("A" & Rows.Count).End(xlUp).Row - 1
            ActiveWorkbook.SaveAs SvPath & MyArr1(Itm1) & Format(Date, " MM-DD-YY") & ".xlsx", 51
            ActiveWorkbook.Close False
            ws1.Range(vTitles1).AutoFilter Field:=vCol1
        Next Itm1
    
    'Cleanup

    This code is much easier and quicker to understand and edit.

    To make things much quicker, please only focus on the code you have problems with. So remove the code that works or at least make it much clearer where your code doesn't do what you want and what you want that bit of code to do.

    Get a bit more working, test it then work on the next problem piece and so on.

    Small tip in the code above, use "yy-mm-dd" date format as that sorts all dates in windows explorer. makes it easier and more likely that you find the latest file.


    Rod Gill
    Author of the one and only Project VBA Book
    www.project-systems.co.nz

    Wednesday, September 2, 2015 9:57 PM
  • Thank you for your advice, I will be more clear in the future

    Regarding my problem with this macro an the thing that i want to do automatically is this:

    I have a workbook with 3 sheets:

    Sheet 1 is named "Info1" and contains this info:

    Name

    Value1

    Value2

    Valentin

    1

    13

    Valentin

    3

    34

    Marian

    3

    445

    Marian

    1

    34

    Mihai

    233

    44

    Florin

    334

    4

    Sheet 2 is named "Info2" and contains :

    Name

    Value1

    Value2

    Value3

    Marian

    3

            tr

    fasfv

    Marian

               e

           fsfs

    fasfa

    Mihai

    233

    44

    favsv

    Florin

    334

    4

    vfas

    Sheet 3 is named "Info3" and contains:

    Name

    Value1

    Value2

    Value3

    Value4

    Value5

    Value6

    Valentin

    1

    13

    dascfc

    fsdf

    fsdfs

    fdfs

    Valentin

    3

    34

    xvzx

    v

    vdvs

    fsdfs

    I need a macro that will split this workbook with 3 sheets mentioned above into multiple workbooks named based on column "Name" : i.e. "Valentin" , "Mihai", "Marian" and "Florin"

    Each workbook will contain 3 sheets with informations from each sheet mentioned above and having the same name

    The macro above only splits the first sheet of the master file into multiple workbooks . When it goes to the second sheet from the master file (Info2) a pop up message appears "A file named "Valentin" already exists. Do you want to replace it?".

    Can you help with this problem?

    I think this segment of the macro should be changed but i haven't figure out how , yet :(

    'Loop through list one value at a time

    For Itm2 = 1 To UBound(MyArr2)
    ws2.Range(vTitles2).AutoFilter Field:=vCol2, Criteria1:=MyArr2(Itm2)
    ws2.Range("A1:A" & LR2).EntireRow.Copy
    Workbooks.Add
    Range("A2").PasteSpecial xlPasteAll
    Cells.Columns.AutoFit
    MyCount2 = MyCount2 + Range("A" & Rows.Count).End(xlUp).Row - 1
    ActiveWorkbook.SaveAs SvPath & MyArr2(Itm2) & Format(Date, " MM-DD-YY") & ".xlsx", 51
    ActiveWorkbook.Close False
    ws2.Range(vTitles2).AutoFilter Field:=vCol2
    Next Itm2

    Thank you in advance,

    Mara

    Thursday, September 3, 2015 12:55 PM
  • Why not a simple loop saving the file once for each name?

    For the already exists message try:

    Application.DisplayAlerts=False
    SaveAs
    Application.DisplayAlerts=True

    Have to reset to true otherwise useful messages won't display.


    Rod Gill
    Author of the one and only Project VBA Book
    www.project-systems.co.nz

    Friday, September 4, 2015 12:55 AM
  • Please see the sample code here.

    http://www.rondebruin.nl/win/s3/win006.htm


    Knowledge is the only thing that I can give you, and still retain, and we are both better off for it.

    Saturday, September 5, 2015 12:41 PM
  • Yep, so once you have the name for the new workbook, why wouldn't a SaveAs work for you?

    Rod Gill
    Author of the one and only Project VBA Book
    www.project-systems.co.nz

    Sunday, September 6, 2015 9:54 PM