Prompt for Folder Select when Merging Multiple Workbooks

FHPM1

New Member
Joined
Nov 8, 2016
Messages
3
Hello,

Would someone be able to let me know how I can edit this code to change the MyPath = "C:" to a prompt for folder location instead?

Thanks FHPM1


Sub MergeAllWorkbooks()
Dim MyPath As String, FilesInPath As String
Dim MyFiles() As String
Dim SourceRcount As Long, FNum As Long
Dim mybook As Workbook, BaseWks As Worksheet
Dim sourceRange As Range, destrange As Range
Dim rnum As Long, CalcMode As Long


' Change this to the path\folder location of your files.
MyPath = "C:"


' Add a slash at the end of the path if needed.
If Right(MyPath, 1) <> "" Then
MyPath = MyPath & ""
End If


' If there are no Excel files in the folder, exit.
FilesInPath = Dir(MyPath & "*.xl*")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If


' Fill the myFiles array with the list of Excel files
' in the search folder.
FNum = 0
Do While FilesInPath <> ""
FNum = FNum + 1
ReDim Preserve MyFiles(1 To FNum)
MyFiles(FNum) = FilesInPath
FilesInPath = Dir()
Loop


' Set various application properties.
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With


' Add a new workbook with one sheet.
Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
rnum = 1


' Loop through all files in the myFiles array.
If FNum > 0 Then
For FNum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(MyPath & MyFiles(FNum))
On Error GoTo 0


If Not mybook Is Nothing Then
On Error Resume Next


' Change this range to fit your own needs.
With mybook.Worksheets(1)
Set sourceRange = .Range("P5")
End With


If Err.Number > 0 Then
Err.Clear
Set sourceRange = Nothing
Else
' If source range uses all columns then
' skip this file.
If sourceRange.Columns.Count >= BaseWks.Columns.Count Then
Set sourceRange = Nothing
End If
End If
On Error GoTo 0


If Not sourceRange Is Nothing Then


SourceRcount = sourceRange.Rows.Count


If rnum + SourceRcount >= BaseWks.Rows.Count Then
MsgBox "There are not enough rows in the target worksheet."
BaseWks.Columns.AutoFit
mybook.Close savechanges:=False
GoTo ExitTheSub
Else


' Copy the file name in column A.
With sourceRange
BaseWks.Cells(rnum, "A"). _
Resize(.Rows.Count).Value = MyFiles(FNum)
End With


' Set the destination range.
Set destrange = BaseWks.Range("B" & rnum)


' Copy the values from the source range
' to the destination range.
With sourceRange
Set destrange = destrange. _
Resize(.Rows.Count, .Columns.Count)
End With
destrange.Value = sourceRange.Value


rnum = rnum + SourceRcount
End If
End If
mybook.Close savechanges:=False
End If


Next FNum
BaseWks.Columns.AutoFit
End If


ExitTheSub:
' Restore the application properties.
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
End Sub
 

Excel Facts

Select a hidden cell
Somehide hide payroll data in column G? Press F5. Type G1. Enter. Look in formula bar while you arrow down through G.
Hello,

Would someone be able to let me know how I can edit this code to change the MyPath = "C:" to a prompt for folder location instead?

Thanks FHPM1
You can change MyPath = "C:" to this:
(You should also consider adding the backslash "\" in your code as it will add it to the MyPath string if it dowsn't exist.)
Code:
Sub MergeAllWorkbooks()
    Dim MyPath As String, FilesInPath As String
    Dim MyFiles() As String
    Dim SourceRcount As Long, FNum As Long
    Dim mybook As Workbook, BaseWks As Worksheet
    Dim sourceRange As Range, destrange As Range
    Dim rnum As Long, CalcMode As Long


    ' Change this to the path\folder location of your files.
    [COLOR=#ff0000]With Application.FileDialog(msoFileDialogFolderPicker)
       .Title = "Choose folder"
       .InitialFileName = "C:\"
       If .Show = -1 Then MyPath = .SelectedItems(1)
    End With[/COLOR]


    ' Add a slash at the end of the path if needed.
    If Right(MyPath, 1) <> "[B][COLOR=#0000ff]\[/COLOR][/B]" Then
        MyPath = MyPath & "[B][COLOR=#0000ff]\[/COLOR][/B]"
    End If
 
Upvote 0
You can change MyPath = "C:" to this:
(You should also consider adding the backslash "\" in your code as it will add it to the MyPath string if it dowsn't exist.)
Code:
Sub MergeAllWorkbooks()
    Dim MyPath As String, FilesInPath As String
    Dim MyFiles() As String
    Dim SourceRcount As Long, FNum As Long
    Dim mybook As Workbook, BaseWks As Worksheet
    Dim sourceRange As Range, destrange As Range
    Dim rnum As Long, CalcMode As Long


    ' Change this to the path\folder location of your files.
    [COLOR=#ff0000]With Application.FileDialog(msoFileDialogFolderPicker)
       .Title = "Choose folder"
       .InitialFileName = "C:\"
       If .Show = -1 Then MyPath = .SelectedItems(1)
    End With[/COLOR]


    ' Add a slash at the end of the path if needed.
    If Right(MyPath, 1) <> "[B][COLOR=#0000ff]\[/COLOR][/B]" Then
        MyPath = MyPath & "[B][COLOR=#0000ff]\[/COLOR][/B]"
    End If

Thanks Bqardi - that solves that problem.
Do you know how I can use this code to run it within an excel doc, so it pastes the information into the cells I want (which has been formatted in the way i want it displayed), rather than starting a new blank excel doc and pasting it to this? I guess it needs changing to run within the template file and choose the destination cells to paste them where I want?
 
Upvote 0

Forum statistics

Threads
1,213,567
Messages
6,114,342
Members
448,570
Latest member
rik81h

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