VBA Open Files From Input Box

ir121973

Active Member
Joined
Feb 9, 2008
Messages
371
Hi, I wonder whether someone may be able to help me please.

I'm using the code below to allow a user to open, and extract a number of 'Source' files creating a "Summary" sheet from the extracted data.

Code:
Sub ConsolidateTimeRecording()
  
    Dim DestWB As Workbook
    Dim dR As Long
    Dim Fd As FileDialog
    Dim LastRow As Long
    Dim SourceSheet As String
    Dim sFile As String
    Dim sPath As String
    Dim StartRow As Long
    Dim wb As Workbook
    Dim ws As Worksheet
    Set DestWB = ActiveWorkbook
  
    SourceSheet = "Input"
    StartRow = 2
    
    Range("B4:N4").Select
    
    Selection.AutoFilter
    
       ' Select the folder that contains the files
    Set Fd = Application.FileDialog(msoFileDialogFolderPicker)
        With Fd
            '.InitialFileName = "DefaultPath"
                If .Show = -1 Then
                    sPath = Fd.SelectedItems(1) & "\"
                End If
        End With
    Set Fd = Nothing
        ' Directory in the folder
        sFile = Dir(sPath)
        Do While sFile <> ""
        Set wb = Workbooks.Open(Filename:=sFile, ReadOnly:=True, Password:="master")
            For Each ws In wb.Worksheets
                If ws.Name = SourceSheet Then
                    With ws
                        If .UsedRange.Cells.count > 1 Then
                            dR = DestWB.Worksheets("Time Recording").Range("B" & DestWB.Worksheets("Time Recording").Rows.count).End(xlUp).Row + 1
                            If dR < 5 Then dR = 6  'destination start row
                                LastRow = .Range("A" & Rows.count).End(xlUp).Row
                                If LastRow >= StartRow Then
                                    .Range("A" & StartRow & ":M" & LastRow).Copy
                                    DestWB.Worksheets("Time Recording").Cells(dR, "B").PasteSpecial xlValues
                                    DestWB.Worksheets("Time Recording").Range("B5:N" & LastRow).Font.Name = "Lucida Sans"
                                    DestWB.Worksheets("Time Recording").Range("B5:N" & LastRow).Font.Size = 10
                                    DestWB.Worksheets("Time Recording").Range("K5:N" & LastRow).NumberFormat = "#,##0.00"
                                    DestWB.Worksheets("Time Recording").Range("K5:N" & LastRow).HorizontalAlignment = xlCenter
                                End If
                            End If
                    End With
            Exit For
        End If
    Next ws
    wb.Close savechanges:=False
    ' Next file in folder
    sFile = Dir
  Loop
  
    Application.CutCopyMode = False
        
    msg = MsgBox("All Time Recording files have been consolidated", vbInformation)
    Columns("B:N").AutoFit
End Sub

I'd now like to make a change to this, but I'm very unsure about how to go about it.

Upon selecting to run the macro, I would like the user to be presented with an 'Input box', so they can type the name of the 'Month' folder they wish to open.

Then, when this action has been performed, automatically open the "Time Recording" sub folder, then automatically and extract the data from the 'Source' files in this, as per the current functionality.

The initial file path is as follows:

\\irf1234\r and d management\D&RM\Reporting\Chris Test

Then the user will enter the 'Month' folder name, so the file path will for example be:

\\irf1234\r and d management\D&RM\Reporting\Chris Test\November

From this, I'd like to automatically open the "Time Recording" subfolder and extract the data from the 'Source' files.

As mentioned earlier in my post, I'm not sure how to proceed with this, but I just wondered whether someone could possibly look at this please and offer some guidance on how may go about achievin this please.

Many thanks and kind regards
 

Excel Facts

When they said...
When they said you are going to "Excel at life", they meant you "will be doing Excel your whole life".
You can give this a try. But be aware that using an input box opens the door for input error by the user. Two quality checks were included in the code, but that might not be enough to assure that users will enter data correctly into the input box.
Code:
Sub ConsolidateTimeRecording()  
    Dim DestWB As Workbook
    Dim dR As Long
    Dim Fd As FileDialog
    Dim LastRow As Long
    Dim SourceSheet As String, sMo As Variant
    Dim sFile As String, mo As String
    'Dim sPath As String
    Dim StartRow As Long
    Dim wb As Workbook
    Dim ws As Worksheet
    Set DestWB = ActiveWorkbook  
    SourceSheet = "Input"
    StartRow = 2
    Range("B4:N4").AutoFilter
    sMo = "January, February, March, April, May, June, July, August, September, October, November, December"
    mo = InputBox("Please enter the month for the file to retrieve, expl: January", "MONTH OF FIle")
        If InStr(sMo, mo) = 0 Or mo = "" Then
            MsgBox "A valid month name was not entered"
            Exit Sub
        End If
        sFile = "[URL="file://\\irf1234\r"]\\irf1234\r[/URL] and d management\D&RM\Reporting\Chris Test\" & mo
        Do While sFile <> ""
        Set wb = Workbooks.Open(Filename:=sFile, ReadOnly:=True, Password:="master")
            For Each ws In wb.Worksheets
                If ws.Name = SourceSheet Then
                    With ws
                        If .UsedRange.Cells.Count > 1 Then
                            dR = DestWB.Worksheets("Time Recording").Range("B" & DestWB.Worksheets("Time Recording").Rows.Count).End(xlUp).Row + 1
                            If dR < 5 Then dR = 6  'destination start row
                                LastRow = .Range("A" & Rows.Count).End(xlUp).Row
                                If LastRow >= StartRow Then
                                    .Range("A" & StartRow & ":M" & LastRow).Copy
                                    DestWB.Worksheets("Time Recording").Cells(dR, "B").PasteSpecial xlValues
                                    DestWB.Worksheets("Time Recording").Range("B5:N" & LastRow).Font.Name = "Lucida Sans"
                                    DestWB.Worksheets("Time Recording").Range("B5:N" & LastRow).Font.Size = 10
                                    DestWB.Worksheets("Time Recording").Range("K5:N" & LastRow).NumberFormat = "#,##0.00"
                                    DestWB.Worksheets("Time Recording").Range("K5:N" & LastRow).HorizontalAlignment = xlCenter
                                End If
                            End If
                    End With
            Exit For
        End If
    Next ws
    wb.Close savechanges:=False
    ' Next file in folder
    sFile = Dir
  Loop  
    Application.CutCopyMode = False        
    msg = MsgBox("All Time Recording files have been consolidated", vbInformation)
    Columns("B:N").AutoFit
End Sub
 
Upvote 0
Hi @JLGWhiz, thank you very much for taking the time to reply to my post and for putting the code together.

I've tried to run the code, and the input box is correctly displayed to the user, but unfortunately I receive an error message telling me that "\\Irf1234\ims r and d management\D&RM\Reporting\Chris TestNovember.xls" cannot be found.

I looked at the file path which was displayed in the error message, and realised that it was not showing November as the folder so I've tried changing the file path in the code to both \\Irf1234\ims r and d management\D&RM\Reporting\Chris Test\ & mo \ and \\Irf1234\ims r and d management\D&RM\Reporting\Chris Test\ & mo \, sadly without success.

I just wondered whether you may be able to look at this and let me know where I've gone wrong.

Many thanks and kind regards
 
Upvote 0
Hi @JLGWhiz, thank you very much for taking the time to reply to my post and for putting the code together.

I've tried to run the code, and the input box is correctly displayed to the user, but unfortunately I receive an error message telling me that "\\Irf1234\ims r and d management\D&RM\Reporting\Chris TestNovember.xls" cannot be found.

I looked at the file path which was displayed in the error message, and realised that it was not showing November as the folder so I've tried changing the file path in the code to both \\Irf1234\ims r and d management\D&RM\Reporting\Chris Test\ & mo \ and \\Irf1234\ims r and d management\D&RM\Reporting\Chris Test\ & mo \, sadly without success.

I just wondered whether you may be able to look at this and let me know where I've gone wrong.

Many thanks and kind regards

In testing the code, I made sure that whichever month was entered for the folder name would be shown as below:
\\irf1234\r and d management\D&RM\Reporting\Chris Test\November
I have reverified that the variable 'sFile' contains that value if November is entered. I noticed that you are showing an additional "\" at the end of the path name, so if you want the additional backslash then change the 'sFile =' line to:
Code:
sFile = "[URL="file://\\irf1234\r"]\\irf1234\r[/URL] and d management\D&RM\Reporting\Chris Test\" & mo & "\"
 
Upvote 0
Hi @JLGWhiz, thank you very much for taking the time to come back to me with this.

I'm currently not at work to test this, so I will come back to you tomorrow to let you know how I've got on.

All the best and kind regards
 
Upvote 0
Hi @JLGWhiz, I hope you are well.

As promised, I said I would get back to you to let you know how I've got on.

With some minor changes to the filepath I think that this is now correct:

sFile = "\\Irf12345\r and d management\D&RM\Reporting\Chris Test\" & mo & "\Time Recording\ "

But unfortunately I'm still receiving a 'Run-time error '1004' \\Irf12345\r and d management\D&RM\Reporting\Chris Test\" & mo & "\Time Recording\.xls' cannot be found. Check that the spelling of the filename, and verify that the location is correct.

Debug highlights this line as the cause:
Code:
Set wb = Workbooks.Open(Filename:=sFile, ReadOnly:=True, Password:="master")

Could you tell me please have you any ideas where I may be going wrong.

Many thanks and kind regards
 
Upvote 0
sFile = "\\Irf12345\r and d management\D&RM\Reporting\Chris Test\" & mo & "\Time Recording\
Remove the last "\". If Time Recording is the file name then it should only be followed by the file extension ".xls" or ".xlsx" or ".xlsm" as the case may be.
 
Upvote 0
Hi @JLGWhiz, thank you very much for coming back to me with this.

My apologies for not making this clear, but "Time Recording" which I want to open automatically and automatically extract the files that are contained within it.

Many thanks and kind regards
 
Upvote 0
Hi @JLGWhiz, thank you very much for coming back to me with this.

My apologies for not making this clear, but "Time Recording" which I want to open automatically and automatically extract the files that are contained within it.

Many thanks and kind regards

I am totally confused. If you manually open the file you are attempting to open with code and in any unused cell type the following.
=CELL("filename")
Type it exactly as shown, do not subtitute a file name for the word 'filename'. Press enter it will give you a complete path. Copy that display and post it back here. Then maybe I can get the code straightened out.
 
Upvote 0
Hi @JLGWhiz, firstly thank you for your patience and your continued help with this, and secondly my apologies for not getting back to you sooner.

Since your last post I've been working on this and I found two posts here Open File With Inputbox Result In The Middle Of The Filename Address & Open All Files In A Folder which have helped me to progress this considerably further.

My code is as follows:

Code:
Sub ConsolidateTimeRecording()

    Dim DestWB As Workbook
    Dim dR As Long
    Dim Fd As FileDialog
    Dim LastRow As Long
    Dim SourceSheet As String
    Dim sFile As String '****New line
    Dim sMidFile As String '****New line
    Dim StartRow As Long
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim path As Variant
    Dim excelfile As Variant
    
    Set DestWB = ActiveWorkbook

    SourceSheet = "Input"
    StartRow = 2

    Range("B4:N4").Select

    Selection.AutoFilter

    MidFile = InputBox("Please Enter The Month You Wish To Open")
    sFile = "D:\Work Files\" & MidFile & "\Time Recording\"

    excelfile = Dir(sFile & "*.xls")
    Do While excelfile <> ""

        Set wb = Workbooks.Open(Filename:=sFile & excelfile, ReadOnly:=True, Password:="master")
            For Each ws In wb.Worksheets
                If ws.Name = SourceSheet Then
                    With ws
                        If .UsedRange.Cells.count > 1 Then
                            dR = DestWB.Worksheets("Time Recording").Range("B" & DestWB.Worksheets("Time Recording").Rows.count).End(xlUp).Row + 1
                            If dR < 5 Then dR = 6  'destination start row
                                LastRow = .Range("A" & Rows.count).End(xlUp).Row
                                If LastRow >= StartRow Then
                                    .Range("A" & StartRow & ":M" & LastRow).Copy
                                    DestWB.Worksheets("Time Recording").Cells(dR, "B").PasteSpecial xlValues
                                    DestWB.Worksheets("Time Recording").Range("B5:N" & LastRow).Font.Name = "Lucida Sans"
                                    DestWB.Worksheets("Time Recording").Range("B5:N" & LastRow).Font.Size = 10
                                    DestWB.Worksheets("Time Recording").Range("K5:N" & LastRow).NumberFormat = "#,##0.00"
                                    DestWB.Worksheets("Time Recording").Range("K5:N" & LastRow).HorizontalAlignment = xlCenter
                                End If
                            End If
                    End With
            Exit For
        End If
    Next ws
    wb.Close savechanges:=False
    ' Next file in folder
        excelfile = Dir
    Loop

    Application.CutCopyMode = False

    msg = MsgBox("All Time Recording files have been consolidated", vbInformation)

    Columns("B:N").AutoFit
End Sub

Now I can get the script to run without any errors, but the problem is, is that it only extracts the information from the first file and I'm not sure why.

I just wondered whether you may be able to look at this please and let me know where I've gone wrong.

Many thanks and kind regards
 
Upvote 0

Forum statistics

Threads
1,214,994
Messages
6,122,633
Members
449,092
Latest member
bsb1122

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