VBA Automatically Open Files In Folder

Hi, I wonder whether someone may be able to help me please.

I'm using the script below to allow a user to open multiple files, extracting a range of information before pasting this into a "Summary" sheet.

Sub MergeOriginal()

      Dim DestWB As Workbook, WB As Workbook, WS As Worksheet, SourceSheet As String
      Set DestWB = ActiveWorkbook
      SourceSheet = "Input"
      StartRow = 2
      FileNames = Application.GetOpenFilename( _
      filefilter:="Excel Files (*.xls*),*.xls*", _
      Title:="Select the workbooks to merge.", MultiSelect:=True)
      If IsArray(FileNames) = False Then
          If FileNames = False Then
              Exit Sub
          End If
      End If
      For n = LBound(FileNames) To UBound(FileNames)
          Set WB = Workbooks.Open(Filename:=FileNames(n), ReadOnly:=True)
          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 n
  End Sub

In it's current for, the user has to select each file to open, but I'd like to adapt this so the user only has to select the folder and the files open automatically and extract the data, but I'm very unsure about how to do this.

I just wondered whether someone could possibly look at this and offer some guidance on how I may go about amending this.

Many thanks and kind regards

Hi Hobbiton73

Try this code

Sub MergeOriginal()
  Dim DestWB As Workbook, WB As Workbook, WS As Worksheet, SourceSheet As String
  Dim StartRow As Long, dR As Long, LastRow As Long
  Dim Fd As FileDialog, sPath As String, sFile As String

  Set DestWB = ActiveWorkbook
  SourceSheet = "Input"
  StartRow = 2
  ' 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)
    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
End Sub

See you later

Hi @BrianM45, thank you for taking the time to reply to my post and for putting the solution together.

I've tried the code you kindly provide, but unfortunately I receive a Run time '1004' error with the message "Sorry, we couldn't find File1.xls. Is it possible it was moved, renamed or deleted". Debug then points to this line:

Set WB = Workbooks.Open(Filename:=sFile, ReadOnly:=True)

This is a little puzzling though because File1 does exist and is in the folder I choose.

Kind regards

sFile just appears to be a file name and not a full path. Suggest incorporating the path as well.

Hi @mrice, thank you for taking the time to reply to my post.

Forgive me for askng, but could you possibly offer a little guidance how I may incorporate the full file path please.

Many thanks and kind regards

Try

Set WB = Workbooks.Open(Filename:=sPath, ReadOnly:=True)

Hi @BrianM45,@mrice,thank you both for taking the time to come back to me with this.

@BrianM45, your amended ccode works great, thank you.

Both, all the best and kind regards

Hi Hobbiton, Hi Mrice

sPath return the path who choose whit back slash
sFile is the file who is in the directory

The correct code is

Set WB = Workbooks.Open(Filename:=sPath & sFile, ReadOnly:=True)

Sorry for my late reply