Save As Input Box for splitting one file into multiple files

[Gem1979]

Hi All

This is my first post so bear with me! Great forum, has been extremely usefull. I am a real VBA novice but pleased with what I've been able to create so far with help from clever people here.

I have a macro set up that splits one worksheet into mutiple files depending on a value in a particular column. At the moment I have to go into the code and amend the desired file path and then the desired file name of the new files before running the macro to split the files. What I would like to do is incorporate an input box so that when the macro is run from a button it asks where you want them saving and what to call them.

I already have an input box that asks what column I want to split the data by. Just not sure how to apply this for saving. I want others with little or no VBA knowledge to be able to use the file without having to amend the code. Any help would be much appreciated

 

[dmt32]

Hi welcome to the board. It would be helpful if you could post the code you want to amend here.

Dave

 

[Gem1979]

Hi Dave

Thank you, here's the full code. Lines in blue are my current save options that I have to amend manually with file path and name.

Sub ParseItems()
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

Set ws = Sheets("Sheet1")

SvPath = "file path\"

vTitles = "A1:AF1"

vCol = Application.InputBox("What column to split data by? " & vbLf _
& vbLf & "(A=1, B=2, C=3, etc)", "Which column?", 1, Type:=1)
If vCol = 0 Then Exit Sub

LR = ws.Cells(ws.Rows.Count, vCol).End(xlUp).Row

Application.ScreenUpdating = False

ws.Columns(vCol).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ws.Range("EE1"), Unique:=True

ws.Columns("EE:EE").Sort Key1:=ws.Range("EE2"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal

MyArr = Application.WorksheetFunction.Transpose(ws.Range("EE2:EE" & Rows.Count).SpecialCells(xlCellTypeConstants))

ws.Range("EE:EE").Clear

ws.Range(vTitles).AutoFilter

For Itm = 1 To UBound(MyArr)
ws.Range(vTitles).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 & "file name " & MyArr(Itm) & ".xlsx"

ActiveWorkbook.Close False

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

ws.AutoFilterMode = False
MsgBox "Rows with data: " & (LR - 1) & vbLf & "Rows copied to other sheets: " & MyCount & vbLf & "Files created, hope they match!!"
Application.ScreenUpdating = True
End Sub

 

[dmt32]

Hi,
see if this update to your code goes in right direction for you.
Ensure that you copy BOTH procedures to your module.

Sub ParseItems()
    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
    Dim SaveDriveDir As String

    Set ws = Sheets("Sheet1")
    SaveDriveDir = CurDir

    SvPath = GetFolder(ThisWorkbook.Path)
    If SvPath = "" Then GoTo ExitSub
    SvPath = SvPath & "\"

    vTitles = "A1:AF1"
    vCol = Application.InputBox("What column to split data by? " & vbLf _
                              & vbLf & "(A=1, B=2, C=3, etc)", "Which column?", 1, Type:=1)
    If vCol = 0 Then Exit Sub
    LR = ws.Cells(ws.Rows.Count, vCol).End(xlUp).Row
    Application.ScreenUpdating = False
    ws.Columns(vCol).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ws.Range("EE1"), Unique:=True
    ws.Columns("EE:EE").Sort Key1:=ws.Range("EE2"), Order1:=xlAscending, Header:=xlYes, _
                             OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
    MyArr = Application.WorksheetFunction.Transpose(ws.Range("EE2:EE" & Rows.Count).SpecialCells(xlCellTypeConstants))
    ws.Range("EE:EE").Clear
    ws.Range(vTitles).AutoFilter
    For Itm = 1 To UBound(MyArr)
        ws.Range(vTitles).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 & "file name " & MyArr(Itm) & ".xlsx"
        ActiveWorkbook.Close False
        ws.Range(vTitles).AutoFilter Field:=vCol
    Next Itm
    ws.AutoFilterMode = False
    MsgBox "Rows with data: " & (LR - 1) & vbLf & "Rows copied to other sheets: " & MyCount & vbLf & "Files created, hope they match!!"

ExitSub:
    Application.ScreenUpdating = True
    On Error Resume Next
    ChDrive SaveDriveDir
    ChDir SaveDriveDir
    On Error GoTo 0
End Sub

Function GetFolder(ByVal sPath As String) As String
    Dim sFolder As FileDialog
    Dim sItem As String
    Set sFolder = Application.FileDialog(msoFileDialogFolderPicker)
    With sFolder
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .ButtonName = "Select Folder"
        .InitialFileName = sPath
        If .Show <> -1 Then GoTo ExitSub
        sItem = .SelectedItems(1)
    End With
ExitSub:
    GetFolder = sItem
    Set sFolder = Nothing
End Function

Hope Helpful

Dave

 

[Gem1979]

That's great, thank you. Gave me the option to select a save folder which is perfect. Only thing is it didn't give an option to change the file name so files were all called 'file name' MyArr.xlsx

Any thoughts? Appreciate you time looking at this

 

[dmt32]

That's great, thank you. Gave me the option to select a save folder which is perfect. Only thing is it didn't give an option to change the file name so files were all called 'file name' MyArr.xlsx

Any thoughts? Appreciate you time looking at this

Hi,
Your Array MyArr(Itm) is in your for Next Loop & thought that you were collecting File Names form Range?

Dave

 

[Gem1979]

Am only collecting part of the file name from the range which is from the column used to split the data into separate files. Still need it to do that but would like the first part of the file name to be optional if possible?

 

[dmt32]

Should be able to use GetSaveAsFileName method - when have moment, will post an update for you to try.

Dave

 

[Gem1979]

Should be able to use GetSaveAsFileName method - when have moment, will post an update for you to try.

Dave

You're a star, thank you! Won't be able to look at it again until Monday so no hurry. Have a great weekend

 

[dmt32]

Hi,</SPAN>
Give this updated code a try & see if it is now doing what you want. I took liberty of amending the inputbox function so user just has to select the required column to split data with the mouse rather than having to type the column number directly.

Ensure that you copy all code below to your module:

Sub ParseItems()
    Dim LR As Long, Itm As Long, MyCount As Long, vCol As Long
    Dim sFileFormat As Integer
    Dim SaveDriveDir As String, vTitles As String, SvPath As String
    Dim vFileName As String, sPrompt As String, FileExt As String
    Dim MyArr As Variant
    Dim ws As Worksheet
    Dim objRange As Range

    Set ws = Sheets("Sheet1")

    'store current directory
    SaveDriveDir = CurDir

    'set prompt
    sPrompt = "Enter File Name Here"

    'display GetSaveAsFileName Dialog
Retry:
    If Not GetSaveAsFile(InitialName:=sPrompt, sFileName:=SvPath) Then
        GoTo ExitSub
    Else
        'extract file name
        'from path
        vFileName = GetName(SvPath)
        'check file name entered
        'if matches prompt default tell user
        If vFileName = sPrompt Then
            MsgBox "Please Enter A New File Name", 48, "File Name Required"
            GoTo Retry
        Else
            'File Type
            FileExt = Right(SvPath, Len(SvPath) - InStrRev(SvPath, ".") + 1)
            'File Format
            sFileFormat = IIf(FileExt = ".xls", -4143, 51)
            'extract file path
            SvPath = Left$(SvPath, InStrRev(SvPath, "\"))
        End If
    End If

    vTitles = "A1:AF1"

    'display inputbox to select column
top:
    On Error Resume Next
    Set objRange = Application.InputBox("Please Select with the Mouse" & Chr(10) & _
                                        "Any Cell in the Column required to split data by." & Chr(10) & Chr(10) & _
                                        "Press OK Button To Continue.", "Select split data Column", , , , , , 8)
    On Error GoTo 0
    If objRange Is Nothing Then
        GoTo ExitSub
    ElseIf objRange.Columns.Count > 1 Then
        GoTo top
    Else
        'pass column number to variable
        vCol = objRange.Column
    End If

    On Error GoTo ExitSub
    LR = ws.Cells(ws.Rows.Count, vCol).End(xlUp).Row

    Application.ScreenUpdating = False
    ws.Columns(vCol).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ws.Range("EE1"), Unique:=True
    ws.Columns("EE:EE").Sort Key1:=ws.Range("EE2"), Order1:=xlAscending, Header:=xlYes, _
                             OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
    MyArr = Application.WorksheetFunction.Transpose(ws.Range("EE2:EE" & Rows.Count).SpecialCells(xlCellTypeConstants))
    ws.Range("EE:EE").Clear
    ws.Range(vTitles).AutoFilter
    For Itm = 1 To UBound(MyArr)
        ws.Range(vTitles).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

         With ActiveWorkbook
            .SaveAs Filename:=SvPath & vFileName & " " & MyArr(Itm) & FileExt, _
                    FileFormat:=sFileFormat, _
                    Password:="", _
                    WriteResPassword:="", _
                    ReadOnlyRecommended:=False, _
                    CreateBackup:=False

            .Close False
        End With

        ws.Range(vTitles).AutoFilter Field:=vCol
    Next Itm
    ws.AutoFilterMode = False
    MsgBox "Rows with data: " & (LR - 1) & vbLf & "Rows copied to other sheets: " & MyCount & vbLf & "Files created, hope they match!!"

ExitSub:
    Application.ScreenUpdating = True
    If Err > 0 Then MsgBox (Error(Err)), 48, "Error"
    ChDrive SaveDriveDir
    ChDir SaveDriveDir
End Sub


Function GetSaveAsFile(ByVal InitialName As String, ByRef sFileName As Variant) As Boolean
    Dim sFilter As String, sTitle As String
    Dim ver As Integer, L As Integer, FilterIndx As Integer
    ver = Val(Application.Version)
    
    sTitle = "Please Select Folder And Enter A File Name Where Shown Below."
    FilterIndx = IIf(ver < 12, 1, 2)
    sFilter = "Excel 2003 (*.xls),*.xls," & _
              "Excel 2007 > (*.xlsx),*.xlsx,"
    sFileName = Application.GetSaveAsFilename(InitialName, sFilter, FilterIndx, sTitle)
    If sFileName = False Then Exit Function
    GetSaveAsFile = True
End Function

Function GetName(strPath As String) As String
    Dim Temp As String
    Temp = Mid$(strPath, InStrRev(strPath, "\") + 1)
    GetName = Left$(Temp, InStrRev(Temp, ".") - 1)
End Function

Hope find change helpful.


Dave</SPAN>