VBA Run time error

[Mr2017]

Hi

I'm trying to import 3 files from a folder called "ExcelFilesToImport" that sits within in the Documents path.

But I get a run time error that says "Sorry, we couldn't find Apples.xlsx. It is possible it was moved, renamed or deleted." (see first screenshot attached).

However, the file is definitely an xlsx file and hasn't been moved, renamed or deleted (see second screenshot attached). When you right-click on it and click on Properties, the type is "Microsoft Excel Worksheet (.xlsx)"

Does anyone know what needs to be corrected in the code at the bottom of this message, please?

The files I'm importing are simple:

File 1 is called Apples and has the text 'Apples' in B3 and the number 1 in B4.
File 2 is called Bananas and has the text 'Bananas' in B3, the number 2 in B4, and the number 3 in B5.
File 3 is called Pears and has the text 'Pears' in B3, the number 3 in B4, and the number 4 in B5 and the number 5 in B6.

I'd like to import all of them, so that the data from each file is pasted into one tab in the active file with the macro.

But I'd like to ensure there is a blank row between the data from each file.

Eg if data from File 1 populates cells B3 and B4 in the imported data tab, then data from File 2 would populate cells B5 (row 4 would be blank) and B6.

Sub ImportInto1Tab()

  Dim FolderPath As String, Filename As String, Sheet As Worksheet, sh As Worksheet

  Dim lr As Long, lc As Long, lr1 As Long

 

  Application.ScreenUpdating = False

  Path = "C:\Users\" & Environ("UserName") & "\Documents\ExcelFilesToImport\"

  'FolderPath = Environ("userprofile") & "\Desktop\Test\"

  'Filename = Dir(FolderPath & "*.xls*")

  Filename = Dir(Path & "*.xls")

  Set sh = Sheets.Add(before:=Sheets(1))

 

  Do While Filename <> ""

    Workbooks.Open Filename:=FolderPath & Filename, ReadOnly:=True

    For Each Sheet In ActiveWorkbook.Sheets

      lr = Sheet.UsedRange.Rows(Sheet.UsedRange.Rows.Count).Row

      lc = Sheet.UsedRange.Columns(Sheet.UsedRange.Columns.Count).Column

      lr1 = sh.UsedRange.Rows(sh.UsedRange.Rows.Count).Row + 1

      Sheet.Range("A1", Sheet.Cells(lr, lc)).Copy sh.Range("A" & lr1)

    Next Sheet

    Workbooks(Filename).Close

    Filename = Dir()

  Loop

 

  Application.ScreenUpdating = True

End Sub

TIA

 

[DanteAmor]

Try this:

Sub ImportInto1Tab()
  Dim sPath As String, sFile As String
  Dim wb As Workbook, sh As Worksheet, sh2 As Worksheet
  Dim lr1 As Long

  Application.ScreenUpdating = False

  With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "Select Folder"
    .AllowMultiSelect = False
    If .Show <> -1 Then Exit Sub
    sPath = .SelectedItems(1) & "\"
  End With
  sFile = Dir(sPath & "*.xls")
  Set sh = Sheets.Add(before:=Sheets(1))

  Do While sFile <> ""
    Set wb = Workbooks.Open(Filename:=sPath & sFile, ReadOnly:=True)
    For Each sh2 In wb.Sheets
      lr1 = sh.UsedRange.Rows(sh.UsedRange.Rows.Count).Row + 1
      sh2.Range("A1", sh2.UsedRange).Copy sh.Range("A" & lr1)
    Next
    wb.Close False
    sFile = Dir()
  Loop
  Application.ScreenUpdating = True
End Sub

 

[Mr2017]

Hi Dante

Thanks for the prompt response.

I tried that and it worked up to the part where it allows a user to select the folder they want to import the files from.

But then then the folder said "No items match your search" and the folder was empty." and the code stopped at this line:

If .Show <> -1 Then Exit Sub

The folder has 3 .xlsx files, so I added an 'x' at the end of the '.xls' in the code to see if it would make a difference. But it didn't....

Do you know why it wouldn't show any files to select, even though there are some .xlsx files in the folder?

I also changed a couple of the files to .xls files (without the 'x' at the end), but it still said the folder was empty?

Your help, so far, is greatly appreciated!

Thanks in advance.

 

[DanteAmor]

Change this

sFile = Dir(sPath & "*.xls")

For this:

sFile = Dir(sPath & "*.xls*")

They must select the folder correctly:

 

[Mr2017]

Hmmm...I tried that, but it still doesn't show any files?

This is the udpdated code with the 'x' after the 's' in "*.xls"

I tried it without the 'x' as well..., but the files I have are .xlsx files.

Sub ImportInto1Tab()
  Dim sPath As String, sFile As String
  Dim wb As Workbook, sh As Worksheet, sh2 As Worksheet
  Dim lr1 As Long

  Application.ScreenUpdating = False

  With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "Select Folder"
    .AllowMultiSelect = False
    If .Show <> -1 Then Exit Sub
    sPath = .SelectedItems(1) & "\"
  End With
  'sFile = Dir(sPath & "*.xlsx")
  sFile = Dir(sPath & "*.xlsx*")
  Set sh = Sheets.Add(before:=Sheets(1))

  Do While sFile <> ""
    Set wb = Workbooks.Open(Filename:=sPath & sFile, ReadOnly:=True)
    For Each sh2 In wb.Sheets
      lr1 = sh.UsedRange.Rows(sh.UsedRange.Rows.Count).Row + 1
      sh2.Range("A1", sh2.UsedRange).Copy sh.Range("A" & lr1)
    Next
    wb.Close False
    sFile = Dir()
  Loop
  Application.ScreenUpdating = True
End Sub

 

[DanteAmor]

The code works for me.
You will have to go back to the previous version where you write the path in the code.