asked on

Split Data in to Workbooks in Respective Folders

Hi,

I Have a piece of code get from Internet and edited to split the Excel Data in to Workbooks based on One Column.

Now I need to Split the data and save in respective sub folders in a folder with First Two Words of the Array + Custom Name

Eg: Array value is The White Fox

Custom Name in Textbox1 is 2018

The Files should be saved in Sub folder Called The White Fox with File Name: The White - 2018

Please advise

The Code is as below

Dim LR As Long, Itm As Long, MyCount As Long, vCol As Long
Dim ws As Worksheet, MyArr As Variant, vTitles As String, SvPath As String

'Sheet with data in it
   Set ws = ActiveSheet
   

'Path to save files into, remember the final \
    SvPath = GetFolder() & "\"
    SvName = "\" & TextBox1.Value

'Range where titles are across top of data, as string, data MUST
'have titles in this row, edit to suit your titles locale

    a = ComboBox3.Value
    r = ComboBox2.Value - 1
    LastCol = ActiveSheet.Range("xfd1").End(xlToLeft).Column
    LastCol = Split(Cells(1, LastCol).Address, "$")(1)
    vTitles = "A1:" & LastCol & r
    titles = r & ":" & r
   
'Choose column to evaluate from, column A = 1, B = 2, etc.
   'vCol = Application.InputBox("What column to split data by? " & vbLf _
        & vbLf & "(A=1, B=2, C=3, etc)", "Which column?", 1, Type:=1)
        
scol = ComboBox1.Value

vCol = Application.Match(scol, ActiveSheet.Rows(a), 0)
vColRef = Split(Cells(1, vCol).Address, "$")(1)

   If vCol = 0 Then Exit Sub

'Spot bottom row of data
   LR = ws.Cells(ws.Rows.Count, vCol).End(xlUp).Row
   
'Speed up macro execution
   Application.ScreenUpdating = False

'Get a temporary list of unique values from key column
    'ws.Columns(vCol).AdvancedFilter action:=xlFilterCopy, CriteriaRange:=ws.Range(vColRef & r & ":" & vColRef & LR), CopyToRange:=ws.Range("EE1"), Unique:=True
    ws.Range(vColRef & r & ":" & vColRef & LR).AdvancedFilter action:=xlFilterCopy, CopyToRange:=ws.Range("EE1"), Unique:=True

    
'Sort the temporary list
    ws.Range("EE2:EE" & Rows.Count).Sort Key1:=ws.Range("EE2"), Order1:=xlAscending, Header:=xlNo, _
       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)
    MyArr = Application.WorksheetFunction.Transpose(ws.Range("EE2:EE" & Rows.Count).SpecialCells(xlCellTypeConstants))

'clear temporary worksheet list
    ws.Range("EE:EE").Clear

'Turn on the autofilter, one column only is all that is needed
    ws.Range(titles).AutoFilter

'Loop through list one value at a time
    For Itm = 1 To UBound(MyArr)
        ws.Range(titles).AutoFilter Field:=vCol, Criteria1:=MyArr(Itm)
        
        ws.Range("A1:A" & LR).EntireRow.Copy
        Workbooks.Add
        Range("A1").PasteSpecial xlPasteAll
        Cells.Columns.AutoFit
        MyCount = MyCount + Range("A" & Rows.Count).End(xlUp).Row - 1
        
        'ActiveWorkbook.SaveAs SvPath & MyArr(Itm), xlNormal
        ActiveWorkbook.SaveAs SvPath & MyArr(Itm) & SvName & ".xlsx", 51   'use for Excel 2007+
        ActiveWorkbook.Close False
        
        ws.Range(titles).AutoFilter Field:=vCol
    Next Itm

'Cleanup
    ws.AutoFilterMode = False
    MsgBox ("Files saved in " & SvPath & vbLf & vbLf & "Rows with data: " & (LR - 1) & vbLf & "Rows copied to other sheets: " & MyCount)
    Application.ScreenUpdating = True
    Unload Me

Open in new window

Roy Cox

I think you need to change the save as to this

ActiveWorkbook.SaveAs SvPath & MyArr(Itm) & "-" & Me.TextBox1.Value & Application.PathSeparator & SvName & ".xlsx", 51    'use for Excel 2007+

Open in new window

Dim LR As Long, Itm As Long, MyCount As Long, vCol As Long
Dim ws As Worksheet, MyArr As Variant, vTitles As String, SvPath As String

'Sheet with data in it
   Set ws = ActiveSheet
   

'Path to save files into, remember the final \
    SvPath = GetFolder() & "\"
    SvName = "\" & TextBox1.Value

'Range where titles are across top of data, as string, data MUST
'have titles in this row, edit to suit your titles locale

    a = ComboBox3.Value
    r = ComboBox2.Value - 1
    LastCol = ActiveSheet.Range("xfd1").End(xlToLeft).Column
    LastCol = Split(Cells(1, LastCol).Address, "$")(1)
    vTitles = "A1:" & LastCol & r
    titles = r & ":" & r
   
'Choose column to evaluate from, column A = 1, B = 2, etc.
   'vCol = Application.InputBox("What column to split data by? " & vbLf _
        & vbLf & "(A=1, B=2, C=3, etc)", "Which column?", 1, Type:=1)
        
scol = ComboBox1.Value

vCol = Application.Match(scol, ActiveSheet.Rows(a), 0)
vColRef = Split(Cells(1, vCol).Address, "$")(1)

   If vCol = 0 Then Exit Sub

'Spot bottom row of data
   LR = ws.Cells(ws.Rows.Count, vCol).End(xlUp).Row
   
'Speed up macro execution
   Application.ScreenUpdating = False

'Get a temporary list of unique values from key column
    'ws.Columns(vCol).AdvancedFilter action:=xlFilterCopy, CriteriaRange:=ws.Range(vColRef & r & ":" & vColRef & LR), CopyToRange:=ws.Range("EE1"), Unique:=True
    ws.Range(vColRef & r & ":" & vColRef & LR).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ws.Range("EE1"), Unique:=True

    
'Sort the temporary list
    ws.Range("EE2:EE" & Rows.Count).Sort Key1:=ws.Range("EE2"), Order1:=xlAscending, Header:=xlNo, _
       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)
    MyArr = Application.WorksheetFunction.Transpose(ws.Range("EE2:EE" & Rows.Count).SpecialCells(xlCellTypeConstants))

'clear temporary worksheet list
    ws.Range("EE:EE").Clear

'Turn on the autofilter, one column only is all that is needed
    ws.Range(titles).AutoFilter

'Loop through list one value at a time
    For Itm = 1 To UBound(MyArr)
        ws.Range(titles).AutoFilter Field:=vCol, Criteria1:=MyArr(Itm)
        
        ws.Range("A1:A" & LR).EntireRow.Copy
        Workbooks.Add
        Range("A1").PasteSpecial xlPasteAll
        Cells.Columns.AutoFit
        MyCount = MyCount + Range("A" & Rows.Count).End(xlUp).Row - 1
        
        'ActiveWorkbook.SaveAs SvPath & MyArr(Itm), xlNormal
        ActiveWorkbook.SaveAs SvPath & MyArr(Itm) & "-" & Me.TextBox1.Value & Application.PathSeparator & SvName & ".xlsx", 51    'use for Excel 2007+
        ActiveWorkbook.Close False
        
        ws.Range(titles).AutoFilter Field:=vCol
    Next Itm

'Cleanup
    ws.AutoFilterMode = False
    MsgBox ("Files saved in " & SvPath & vbLf & vbLf & "Rows with data: " & (LR - 1) & vbLf & "Rows copied to other sheets: " & MyCount)
    Application.ScreenUpdating = True
    Unload Me

Open in new window

Ajay Krishnan

ASKER

Hi Roy,

Thank you for the Quick reply

But Now the Code will return as

The White Fox - 2018\2018

What I need is The White Fox\The White - 2018.xlsx

Please help

Roy Cox

Do the sub folders already exist?

Can you attach an example with the userform in.

Roy Cox

Let me know if this is closer

''/// assumes the item starts with The
        ActiveWorkbook.SaveAs SvPath & MyArr(Itm) & Right(svname, Len(svname) & "-" & Me.TextBox1.Value - 4) & ".xlsx", 51 'use for Excel 2007+

Open in new window

Ajay Krishnan

ASKER

Please see the attached File.

I Need to Split the data to Supplier Folders in C with First 2 Words from Supplier name and Week Number I am Giving in Textbox1 just Like

First file will be

C:\DIRECT TRADING\DIRECT TRADING - WEEK 29.xlsx

Second One

C:\AL BOOM MARINE-CONSIGNMENT\AL BOOM - WEEK 29.xlsx

third One

C:\AL BOOM MARINE\AL BOOM - WEEK 29.xlsx

Like that
AHQ-Add-in.xlam

Ajay Krishnan

ASKER

Apologies.

Please see the attached file
AHQ.xlsm

Roy Cox

Is the week number manually entered in TextBox1?

Ajay Krishnan

ASKER

yes,

Some Times instead of week number, there will be other references. so that part need to be manual

Roy Cox

Can you test this

Private Sub CommandButton1_Click()

    Dim LR As Long, Itm As Long, MyCount As Long, vCol As Long
    Dim ws As Worksheet, MyArr As Variant, vTitles As String, SvPath As String

    'Sheet with data in it
    Set ws = ActiveSheet


    'Path to save files into, remember the final \
    SvPath = "C:\Supplier Reports\"
  

    'Range where titles are across top of data, as string, data MUST
    'have titles in this row, edit to suit your titles locale

    a = ComboBox3.Value
    r = ComboBox2.Value - 1
    LastCol = ActiveSheet.Range("xfd1").End(xlToLeft).Column
    LastCol = Split(Cells(1, LastCol).Address, "$")(1)
    vTitles = "A1:" & LastCol & r
    titles = r & ":" & r

    'Choose column to evaluate from, column A = 1, B = 2, etc.
    'vCol = Application.InputBox("What column to split data by? " & vbLf _
     & vbLf & "(A=1, B=2, C=3, etc)", "Which column?", 1, Type:=1)

    scol = ComboBox1.Value

    vCol = Application.Match(scol, ActiveSheet.Rows(a), 0)
    vColRef = Split(Cells(1, vCol).Address, "$")(1)

    If vCol = 0 Then Exit Sub

    'Spot bottom row of data
    LR = ws.Cells(ws.Rows.Count, vCol).End(xlUp).Row

    'Speed up macro execution
    Application.ScreenUpdating = False

    'Get a temporary list of unique values from key column
    'ws.Columns(vCol).AdvancedFilter action:=xlFilterCopy, CriteriaRange:=ws.Range(vColRef & r & ":" & vColRef & LR), CopyToRange:=ws.Range("EE1"), Unique:=True
    ws.Range(vColRef & r & ":" & vColRef & LR).AdvancedFilter action:=xlFilterCopy, CopyToRange:=ws.Range("EE1"), Unique:=True


    'Sort the temporary list
    ws.Range("EE2:EE" & Rows.Count).Sort Key1:=ws.Range("EE2"), Order1:=xlAscending, Header:=xlNo, _
                                         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)
    MyArr = Application.WorksheetFunction.Transpose(ws.Range("EE2:EE" & Rows.Count).SpecialCells(xlCellTypeConstants))

    'clear temporary worksheet list
    ws.Range("EE:EE").Clear

    'Turn on the autofilter, one column only is all that is needed
    ws.Range(titles).AutoFilter

    'Loop through list one value at a time
    For Itm = 1 To UBound(MyArr)
        ws.Range(titles).AutoFilter Field:=vCol, Criteria1:=MyArr(Itm)

        ws.Range("A1:A" & LR).EntireRow.Copy
        Workbooks.Add
        Range("A1").PasteSpecial xlPasteAll
        Cells.Columns.AutoFit
        MyCount = MyCount + Range("A" & Rows.Count).End(xlUp).Row - 1

        'ActiveWorkbook.SaveAs SvPath & MyArr(Itm), xlNormal
        svname = "\" & Left(Myarr(Itm), InStr(InStr(1, MyArr(Itm), " ") + 1, MyArr(Itm), " ", vbTextCompare) - 1) & TextBox1.Value
        ActiveWorkbook.SaveAs SvPath & MyArr(Itm) & svname & ".xlsx", 51   'use for Excel 2007+
        ActiveWorkbook.Close False

        ws.Range(titles).AutoFilter Field:=vCol
    Next Itm

    'Cleanup
    ws.AutoFilterMode = False
    MsgBox ("Files saved in " & SvPath & vbLf & vbLf & "Rows with data: " & (LR - 1) & vbLf & "Rows copied to other sheets: " & MyCount)
    Application.ScreenUpdating = True
    Unload Me

End Sub

Open in new window

Edited: correct typo

Roy Cox

I have to go out for an hour or so, I'll check back later. I've corrected a typo in the last code but I think this is possibly better

Private Sub CommandButton1_Click()

    Dim LR As Long, Itm As Long, MyCount As Long, vCol As Long
    Dim ws As Worksheet, MyArr As Variant, vTitles As String, SvPath As String, MyStr As String

    'Sheet with data in it
    Set ws = ActiveSheet


    'Path to save files into, remember the final \
    SvPath = "C:\Supplier Reports\"
  

    'Range where titles are across top of data, as string, data MUST
    'have titles in this row, edit to suit your titles locale

    a = ComboBox3.Value
    r = ComboBox2.Value - 1
    LastCol = ActiveSheet.Range("xfd1").End(xlToLeft).Column
    LastCol = Split(Cells(1, LastCol).Address, "$")(1)
    vTitles = "A1:" & LastCol & r
    titles = r & ":" & r

    'Choose column to evaluate from, column A = 1, B = 2, etc.
    'vCol = Application.InputBox("What column to split data by? " & vbLf _
     & vbLf & "(A=1, B=2, C=3, etc)", "Which column?", 1, Type:=1)

    scol = ComboBox1.Value

    vCol = Application.Match(scol, ActiveSheet.Rows(a), 0)
    vColRef = Split(Cells(1, vCol).Address, "$")(1)

    If vCol = 0 Then Exit Sub

    'Spot bottom row of data
    LR = ws.Cells(ws.Rows.Count, vCol).End(xlUp).Row

    'Speed up macro execution
    Application.ScreenUpdating = False

    'Get a temporary list of unique values from key column
    'ws.Columns(vCol).AdvancedFilter action:=xlFilterCopy, CriteriaRange:=ws.Range(vColRef & r & ":" & vColRef & LR), CopyToRange:=ws.Range("EE1"), Unique:=True
    ws.Range(vColRef & r & ":" & vColRef & LR).AdvancedFilter action:=xlFilterCopy, CopyToRange:=ws.Range("EE1"), Unique:=True


    'Sort the temporary list
    ws.Range("EE2:EE" & Rows.Count).Sort Key1:=ws.Range("EE2"), Order1:=xlAscending, Header:=xlNo, _
                                         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)
    MyArr = Application.WorksheetFunction.Transpose(ws.Range("EE2:EE" & Rows.Count).SpecialCells(xlCellTypeConstants))

    'clear temporary worksheet list
    ws.Range("EE:EE").Clear

    'Turn on the autofilter, one column only is all that is needed
    ws.Range(titles).AutoFilter

    'Loop through list one value at a time
    For Itm = 1 To UBound(MyArr)
        ws.Range(titles).AutoFilter Field:=vCol, Criteria1:=MyArr(Itm)

        ws.Range("A1:A" & LR).EntireRow.Copy
        Workbooks.Add
        Range("A1").PasteSpecial xlPasteAll
        Cells.Columns.AutoFit
        MyCount = MyCount + Range("A" & Rows.Count).End(xlUp).Row - 1

        'ActiveWorkbook.SaveAs SvPath & MyArr(Itm), xlNormal
        MyStr = Left(MyArr(Itm), InStr(InStr(1, MyArr(Itm), " ") + 1, MyArr(Itm), " ", vbTextCompare) - 1)
        svname = "\" & MyStr & TextBox1.Value
        ActiveWorkbook.SaveAs SvPath & MyStr & "\" & MyArr(Itm) & svname & ".xlsx", 51  'use for Excel 2007+
        ActiveWorkbook.Close False

        ws.Range(titles).AutoFilter Field:=vCol
    Next Itm

    'Cleanup
    ws.AutoFilterMode = False
    MsgBox ("Files saved in " & SvPath & vbLf & vbLf & "Rows with data: " & (LR - 1) & vbLf & "Rows copied to other sheets: " & MyCount)
    Application.ScreenUpdating = True
    Unload Me

End Sub

Open in new window

Ajay Krishnan

ASKER

Hi,

Its kicking me an Error at this Line

      MyStr = Left(MyArr(Itm), InStr(InStr(1, MyArr(Itm), " ") + 1, MyArr(Itm), " ", vbTextCompare) - 1)

Open in new window

Please see attached
Untitled.png

Roy Cox

I stripped all the unnecessary code to check my addition. It worked fine when I manually entered a supplier to work with. ( i added the dash back)

When I ran it in full I discovered it errors with the supplier ADMIRALS
. This is because it is looking for a name with at least two words.
AHQ.xlsm

Ajay Krishnan

ASKER

Sorry,

I was out of the city for a week.

Is there a chance to put a rule if One Word is there it will take that otherwise two words like that?

Thanks

Roy Cox

I'll take a look later.

Roy Cox

Check if this works

Private Sub CommandButton1_Click()


    Dim LR As Long, Itm As Long, MyCount As Long, vCol As Long
    Dim ws As Worksheet, MyArr As Variant, vTitles As String, SvPath As String, MyStr As String

    'Sheet with data in it
    Set ws = ActiveSheet


    'Path to save files into, remember the final \
    SvPath = "C:\Supplier Reports\"
  

    'Range where titles are across top of data, as string, data MUST
    'have titles in this row, edit to suit your titles locale

    a = ComboBox3.Value
    r = ComboBox2.Value - 1
    LastCol = ActiveSheet.Range("xfd1").End(xlToLeft).Column
    LastCol = Split(Cells(1, LastCol).Address, "$")(1)
    vTitles = "A1:" & LastCol & r
    titles = r & ":" & r

    'Choose column to evaluate from, column A = 1, B = 2, etc.
'    vCol = Application.InputBox("What column to split data by? " & vbLf _
'     & vbLf & "(A=1, B=2, C=3, etc)", "Which column?", 1, Type:=1)

    scol = ComboBox1.Value

    vCol = Application.Match(scol, ActiveSheet.Rows(a), 0)
    vColRef = Split(Cells(1, vCol).Address, "$")(1)

    If vCol = 0 Then Exit Sub

    'Spot bottom row of data
    LR = ws.Cells(ws.Rows.Count, vCol).End(xlUp).Row

    'Speed up macro execution
    Application.ScreenUpdating = False

    'Get a temporary list of unique values from key column
    ws.Columns(vCol).AdvancedFilter action:=xlFilterCopy, CriteriaRange:=ws.Range(vColRef & r & ":" & vColRef & LR), CopyToRange:=ws.Range("EE1"), Unique:=True
    ws.Range(vColRef & r & ":" & vColRef & LR).AdvancedFilter action:=xlFilterCopy, CopyToRange:=ws.Range("EE1"), Unique:=True


    'Sort the temporary list
    ws.Range("EE2:EE" & Rows.Count).Sort Key1:=ws.Range("EE2"), Order1:=xlAscending, Header:=xlNo, _
                                         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)
    MyArr = Application.WorksheetFunction.Transpose(ws.Range("EE2:EE" & Rows.Count).SpecialCells(xlCellTypeConstants))

    'clear temporary worksheet list
    ws.Range("EE:EE").Clear

    'Turn on the autofilter, one column only is all that is needed
    ws.Range(titles).AutoFilter

    'Loop through list one value at a time
    For Itm = 1 To UBound(MyArr)
        ws.Range(titles).AutoFilter Field:=vCol, Criteria1:=MyArr(Itm)

        ws.Range("A1:A" & LR).EntireRow.Copy
        Workbooks.Add
        Range("A1").PasteSpecial xlPasteAll
        Cells.Columns.AutoFit
        MyCount = MyCount + Range("A" & Rows.Count).End(xlUp).Row - 1

        'ActiveWorkbook.SaveAs SvPath & MyArr(Itm), xlNormal
        On Error GoTo arr_err
        MyStr = Left(MyArr(Itm), InStr(InStr(1, MyArr(Itm), " ") + 1, MyArr(Itm), " ", vbTextCompare) - 1)
carry_on:
        svname = "\" & MyStr & "-" & TextBox1.Value
       ActiveWorkbook.SaveAs SvPath & MyStr & "\" & svname & ".xlsx", 51   'use for Excel 2007+
'       ActiveWorkbook.SaveAs SvPath & MyStr & "\" & MyArr(Itm) & svname & ".xlsx", 51  'use for Excel 2007+
        ActiveWorkbook.Close False

        ws.Range(titles).AutoFilter Field:=vCol
    Next Itm

    'Cleanup
    ws.AutoFilterMode = False
    MsgBox ("Files saved in " & SvPath & vbLf & vbLf & "Rows with data: " & (LR - 1) & vbLf & "Rows copied to other sheets: " & MyCount)
    Application.ScreenUpdating = True
    Unload Me
arr_err:
Err.Clear
Resume carry_on
End Sub

Open in new window

ASKER CERTIFIED SOLUTION

Roy Cox

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

Roy Cox

I've made all adjustments to the code as requested