Converting Macro that looks at a specific Folder to one that looks for a Directory.

Falko26

Board Regular
Joined
Oct 13, 2021
Messages
89
Office Version
  1. 365
Platform
  1. Windows
Hi Team,

I currently have a Macro that works perfectly by looking at a specific Folder for the files it is pulling data from. Is there a simple way to convert it so it uses the File Picker instead so I can chose which folder it is looking at each time I run the Macro?

Thanks in Advance.

Code:
Sub Test()

            Dim stgF As String, stgP As String
            Dim wb As Workbook
            Dim ws As Worksheet
            Set ws = "C:\Documents\General CAD\_Blank Project\Supporting Files\Weld Log\"
        
            stgP = Application.FileDialog(msoFileDialogFilePicker)
            stgF = Dir(stgP & "\*.xls*")
        

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False

            Do While stgF <> vbNullString
            
                    Set wb = Workbooks.Open(stgP & "\" & stgF)
                
                    With wb.Sheets(1)
                            .UsedRange.Offset(1).Copy ws.Range("A" & Rows.Count).End(3)(2)
                            ws.Columns.AutoFit
                    End With
                
                            wb.Close Save = True
                            stgF = Dir()
            Loop
            
Columns("A:E").Select
Selection.ColumnWidth = 19
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub
 

Excel Facts

Which came first: VisiCalc or Lotus 1-2-3?
Dan Bricklin and Bob Frankston debuted VisiCalc in 1979 as a Visible Calculator. Lotus 1-2-3 debuted in the early 1980's, from Mitch Kapor.
VBA Code:
Option Explicit
Sub UseFileDialogOpen()


    'The following has been adapted from here:
    'https://msdn.microsoft.com/en-us/vba/excel-vba/articles/application-filedialog-property-excel


    Dim lngCount As Long


    'Open the file dialog
    With Application.FileDialog(msoFileDialogOpen)
        .AllowMultiSelect = True
        .Show
        'Display paths of each file selected
        For lngCount = 1 To .SelectedItems.Count
            'MsgBox .SelectedItems(lngCount)
            CreateObject("Shell.Application").ShellExecute .SelectedItems(lngCount)
        Next lngCount
    End With


End Sub
 
Upvote 0
Hey Logit Thanks for the quick Reply,

however I'm not quite sure how to adapt that into my script. Essentially what my scrip does is copy data from a specific range from all workbooks in a specific folder and pastes that info in series to the master workbook I'm currently in. Right now whenever I need to switch the location I need to go into the VBA and paste the new location over the old one. I have other team members working with these macros and I'd rather not have them switching the Code Manually every time they need to switch folders.

If someone could take my code and adapt it to being able to pick the folder instead of relying on the specific path in the code that would be much appreciated.

I pasted my Test Macro before on accident please ignore that. Here is my actual Macro.

Thanks Again,

VBA Code:
Sub BLC_Data_Combine()

            Dim stgF As String, stgP As String
            Dim wb As Workbook
            Dim ws As Worksheet
            Set ws = ActiveWorkbook.Worksheets("Reference")
        
            stgP = "C:\BLC- Blank Project\Isometric\Single Spool_ANSI-B\ProdIsos\Drawings\"  '---->Insert your file path.
            stgF = Dir(stgP & "\*.xls*")
        

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False

            Do While stgF <> vbNullString
            
                    Set wb = Workbooks.Open(stgP & "\" & stgF)
                
                    With wb.Sheets(1)
                            .UsedRange.Offset(1).Copy ws.Range("A" & Rows.Count).End(3)(2)
                            ws.Columns.AutoFit
                    End With
                
                            wb.Close Save = True
                            stgF = Dir()
            Loop
            
Columns("A:E").Select
Selection.ColumnWidth = 19
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub
 
Upvote 0
Hey Team,

I was able to figure it out. I added functions to find folder path using the folder picker then set my folder path to that.

Might not be the cleanest way of doing things but it did accomplish my goal.

VBA Code:
Sub BLC_DataCombine()

            Dim stgF As String, stgP As String
            Dim wb As Workbook
            Dim ws As Worksheet
            Set ws = ActiveWorkbook.Worksheets("Reference")
        
                Dim fileExplorer As FileDialog
                Set fileExplorer = Application.FileDialog(msoFileDialogFolderPicker)
                Dim folderPath As String

                    fileExplorer.AllowMultiSelect = False

                    With fileExplorer
                    If .Show = -1 Then 'Any folder is selected
                    folderPath = .SelectedItems.Item(1)
                    
                End If
                End With
                
            stgP = folderPath  '---->Insert your file path.
            stgF = Dir(stgP & "\*.xls*")
        

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False

            Do While stgF <> vbNullString
            
                    Set wb = Workbooks.Open(stgP & "\" & stgF)
                
                    With wb.Sheets(1)
                            .UsedRange.Offset(1).Copy ws.Range("A" & Rows.Count).End(3)(2)
                            ws.Columns.AutoFit
                    End With
                
                            wb.Close Save = True
                            stgF = Dir()
            Loop
            
Columns("A:E").Select
Selection.ColumnWidth = 19
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub
 
Upvote 0
Solution

Forum statistics

Threads
1,213,546
Messages
6,114,251
Members
448,556
Latest member
peterhess2002

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