Add input box to select folder for output or separated files

Poppyrob

New Member
Joined
Jan 23, 2023
Messages
14
Office Version
  1. 365
  2. 2021
Platform
  1. Windows
In this code, it is currently coded in where to send the output files. I would like to have a input box for the user to select where they want the files to go. Currently its C:Test.

VBA Code:
Option Explicit

Sub ExportToWorkbooks()
    
    Const aibPrompt As String = "Which column would you like to filter by?"
    Const aibtitle As String = "Filter Column"
    Const aibDefault As Long = 3
    
    Dim dFileExtension As String: dFileExtension = ".xlsx"
    Dim dFileFormat As XlFileFormat: dFileFormat = xlOpenXMLWorkbook
    Dim dFolderPath As String: dFolderPath = "C:\Test\"
    
    If Right(dFolderPath, 1) <> "\" Then dFolderPath = dFolderPath & "\"
    If Len(Dir(dFolderPath, vbDirectory)) = 0 Then Exit Sub ' folder not found
    If Left(dFileExtension, 1) <> "." Then dFileExtension = "." & dFileExtension
    
    Application.ScreenUpdating = False
    
    Dim sCol As Variant
    sCol = Application.InputBox(aibPrompt, aibtitle, aibDefault, , , , , 1)
    If Len(CStr(sCol)) = 0 Then Exit Sub ' no entry
    If sCol = False Then Exit Sub ' canceled
    
    Dim sws As Worksheet: Set sws = ActiveSheet
    If sws.FilterMode Then sws.ShowAllData
    Dim srg As Range: Set srg = sws.Range("A1").CurrentRegion
    Dim srCount As Long: srCount = srg.Rows.Count
    If srCount < 3 Then Exit Sub ' not enough rows
    Dim srrg As Range: Set srrg = srg.Rows(1) ' to copy column widths
    Dim scrg As Range: Set scrg = srg.Columns(sCol)
    Dim scData As Variant: scData = scrg.Value
    
    ' Write the unique values from the 1st column to a dictionary.
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare ' case insensitive
    
    Dim Key As Variant
    Dim r As Long
    
    For r = 2 To srCount
        Key = scData(r, 1)
        If Not IsError(Key) Then ' exclude error values
            If Len(Key) > 0 Then ' exclude blanks
                dict(Key) = Empty
            End If
        End If
    Next r
    If dict.Count = 0 Then Exit Sub ' only error values and blanks
    Erase scData
    
    Dim dwb As Workbook
    Dim dws As Worksheet
    Dim dfcell As Range
    Dim dFilePath As String
    
    For Each Key In dict.Keys
        ' Add a new (destination) workbook and reference the first cell.
        Set dwb = Workbooks.Add(xlWBATWorksheet) ' one worksheet
        Set dws = dwb.Worksheets(1)
        Set dfcell = dws.Range("A1")
        ' Copy/Paste
        srrg.Copy
        dfcell.PasteSpecial xlPasteColumnWidths
        srg.AutoFilter sCol, Key
        srg.SpecialCells(xlCellTypeVisible).Copy dfcell
        sws.ShowAllData
        dfcell.Select
        ' Save/Close
        dFilePath = dFolderPath & Key & dFileExtension ' build the file path
        Application.DisplayAlerts = False ' overwrite without confirmation
        dwb.SaveAs dFilePath, xlOpenXMLWorkbook
        Application.DisplayAlerts = True
        dwb.Close SaveChanges:=False
    Next Key
    
    sws.AutoFilterMode = False
    Application.ScreenUpdating = True
    
    MsgBox "Data exported.", vbInformation
    
End Sub
 

Excel Facts

Lock one reference in a formula
Need 1 part of a formula to always point to the same range? use $ signs: $V$2:$Z$99 will always point to V2:Z99, even after copying
I have it working, but it does not put them into the target folder. Always one folder down.

VBA Code:
Option Explicit

Sub ExportToWorkbooks()
    
    Const aibPrompt As String = "Which column would you like to filter by?"
    Const aibtitle As String = "Filter Column"
    Const aibDefault As Long = 3
    
    Dim dFileExtension As String: dFileExtension = ".xlsx"
    Dim dFileFormat As XlFileFormat: dFileFormat = xlOpenXMLWorkbook
    Dim FldrPicker As FileDialog
    Dim myFolder As String

'Have User Select Folder to Save to with Dialog Box
  Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)

  With FldrPicker
    .Title = "Select A Target Folder"
    .AllowMultiSelect = False
    If .Show <> -1 Then Exit Sub 'Check if user clicked cancel button
    myFolder = .SelectedItems(1) & "\"
  End With
  
'Carry out rest of your code here....
    MsgBox "Folder Path is: " & myFolder

    
    Application.ScreenUpdating = False
    
    Dim sCol As Variant
    sCol = Application.InputBox(aibPrompt, aibtitle, aibDefault, , , , , 1)
    If Len(CStr(sCol)) = 0 Then Exit Sub ' no entry
    If sCol = False Then Exit Sub ' canceled
    
    Dim sws As Worksheet: Set sws = ActiveSheet
    If sws.FilterMode Then sws.ShowAllData
    Dim srg As Range: Set srg = sws.Range("A1").CurrentRegion
    Dim srCount As Long: srCount = srg.Rows.Count
    If srCount < 3 Then Exit Sub ' not enough rows
    Dim srrg As Range: Set srrg = srg.Rows(1) ' to copy column widths
    Dim scrg As Range: Set scrg = srg.Columns(sCol)
    Dim scData As Variant: scData = scrg.Value
    
    ' Write the unique values from the 1st column to a dictionary.
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare ' case insensitive
    
    Dim Key As Variant
    Dim r As Long
    
    For r = 2 To srCount
        Key = scData(r, 1)
        If Not IsError(Key) Then ' exclude error values
            If Len(Key) > 0 Then ' exclude blanks
                dict(Key) = Empty
            End If
        End If
    Next r
    If dict.Count = 0 Then Exit Sub ' only error values and blanks
    Erase scData
    
    Dim dwb As Workbook
    Dim dws As Worksheet
    Dim dfcell As Range
    Dim dFilePath As String
    Dim DateText As String: DateText = Format(Date, "_mm_yyyy")
    
    For Each Key In dict.Keys
        ' Add a new (destination) workbook and reference the first cell.
        Set dwb = Workbooks.Add(xlWBATWorksheet) ' one worksheet
        Set dws = dwb.Worksheets(1)
        Set dfcell = dws.Range("A1")
        ' Copy/Paste
        srrg.Copy
        dfcell.PasteSpecial xlPasteColumnWidths
        srg.AutoFilter sCol, Key
        srg.SpecialCells(xlCellTypeVisible).Copy dfcell
        sws.ShowAllData
        dfcell.Select
        ' Save/Close
        dFilePath = Key & DateText & dFileExtension  ' build the file path
        Application.DisplayAlerts = False ' overwrite without confirmation
        dwb.SaveAs dFilePath, xlOpenXMLWorkbook
        Application.DisplayAlerts = True
        dwb.Close SaveChanges:=False
    Next Key
    
    sws.AutoFilterMode = False
    Application.ScreenUpdating = True
    
    MsgBox "Data exported.", vbInformation
    
End Sub
 
Upvote 0
Got it .. had to update the dfilepath to include myFolder.
 
Upvote 0
Solution

Forum statistics

Threads
1,223,884
Messages
6,175,173
Members
452,615
Latest member
bogeys2birdies

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top