VBA Open Files From Input Box

[ir121973]

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.

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

 

[ir121973]

Hi JLGWhiz, just a very quick note to let you know that I've got this working in it's entirety.

My final code is as follows:

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 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

I just wanted to thank you for all your time trouble and patience.

All the best and kind regards

 

[JLGWhiz]

I now see that the month is an echelon above "Time Recording" in the Directory path. That reallly had me baffled. I also now understand more of what you are trying to do.

I don't see anything wrong with the code. If you have more than one file with the same month, then using the DIR() function should allow you to open them in sequence according to the code. Note that IF. What I suspect is that by inserting the month into the directory path, the files are being saved originally in individual directories based on month and will contain only one file per directory.
One thing I don't understand the significance of is this snippet:

Range("B4:N4").Select
    Selection.AutoFilter

It does not appear to do anything, since there is not field or criteria entered. I would think it is a remnant of some previous code and could be deleted without doing any damage to your other code.

To check how many files are in the same folder as the workbook you open, copy this snippet to that workbook code module and run it. A message box will give you the count.

Sub dk()
Dim s As String
s = Dir(ThisWorkbook.path & "\*.*")
    Do While s <> ""
    x = x + 1
    s = Dir
    Loop
    MsgBox x
End Sub

 

[JLGWhiz]

glad you got it working, Thanks for the feedback.
Regards, JLG