Loop VBA macro to open files in a folder, import row, then move to another folder using relative paths

Question

I am attempting to make a loop VBA macro to:

1. Open first file in folder called New
2. Copy data row in Defined Name cell range export_data
3. Paste it into my current workbook on a new row at A1 on Sheet1
4. Close without saving file from which data was imported and move it to Archived folder
5. Repeat until no files left in New folder.

My file structure is as follows:

All files in the New folder are identical (except name) .xlsm files. Each has a Defined Name cell range called export_data with the single row of cells I need to import into my Dashboard.xlsm.

I would like the macro to use relative paths for the New and Archived folders as it would allow me to move the entire set of files anywhere and still work.

At present I have gotten as far as adapting as best I could the code from this post trying to get the macro to move the files:

Option Explicit


Const FOLDER_PATH = "C:\Users\OneDrive\Projects\Audit Sheet\"  'REMEMBER END BACKSLASH

Sub ImportWorksheets()
   '=============================================
   'Process all Excel files in specified folder
   '=============================================
   Dim sFile As String           'file to process
   Dim wsTarget As Worksheet
   Dim wbSource As Workbook
   Dim wsSource As Worksheet
   Dim rowTarget As Long         'output row

   rowTarget = 2

   'check the folder exists
   If Not FileFolderExists(FOLDER_PATH) Then
      MsgBox "Specified folder does not exist, exiting!"
      Exit Sub
   End If

   'reset application settings in event of error
   On Error GoTo errHandler
   Application.ScreenUpdating = False



   'loop through the Excel files in the folder
   sFile = Dir(FOLDER_PATH & "*.xls*")
   Do Until sFile = ""

      'open the source file and set the source worksheet - ASSUMED WORKSHEET(1)
      Set wbSource = Workbooks.Open(FOLDER_PATH & sFile)
      'Set wsSource = wbSource.Worksheets(1) 'EDIT IF NECESSARY

      'import the data

      'close the source workbook, increment the output row and get the next file
      wbSource.Close SaveChanges:=False
      'rowTarget = rowTarget + 1

      sFile = Dir()
   Loop

errHandler:
   On Error Resume Next
   Application.ScreenUpdating = True

   'tidy up
   Set wsSource = Nothing
   Set wbSource = Nothing
   Set wsTarget = Nothing
End Sub




Private Function FileFolderExists(strPath As String) As Boolean
    If Not Dir(strPath, vbDirectory) = vbNullString Then FileFolderExists = True
End Function

Answer 1

Your frustration became my frustration for a while, but alas, tested and working:

This will:

1. Cycle through each file as you specified
2. Save a unchanged copy in RelativePath > Archived
3. Add code to do what you want to do (here, Add Sheet)
4. Save the updated copy in RelativePath > New
5. Delete the original file

The SaveAs file paths are relative as you asked. However, if you move the folder which contains your original excels, you will have to update the variable RelativePath, nothing else will need to be modified though. To make this completely dynamic, you will need to find a way to dynamically assign the path to RelativePath (File Dialogue instead?)

This will error out if there is no folder "Archived" or "New" in the same directory as the workbooks you are opening.

Option Explicit
Const RelativePath = "C:\urdearboy\Desktop\Test\"

Sub ImportWorksheets()
Dim sFile As String
Dim wbSource As Workbook

Dim wbArchive As String, wbNew As String, KillFile As String

If Not FileFolderExists(RelativePath) Then
    MsgBox "Specified folder does not exist, exiting!"
    Exit Sub
End If

Application.ScreenUpdating = False
Application.DisplayAlerts = False

sFile = Dir(RelativePath & "*.xls*")
Do Until sFile = ""

Set wbSource = Workbooks.Open(RelativePath & sFile)
KillFile = wbSource.Path & "\" & wbSource.Name

    'Save Archive
    wbArchive = RelativePath & "Archived\" & wbSource.Name
    wbSource.SaveAs Filename:=wbArchive

        'Do your thing here (I'm just adding a sheet to test code)
        wbSource.Sheets.Add

    'Save new file with changes that are made above
    wbNew = RelativePath & "New\" & wbSource.Name
    wbSource.SaveAs Filename:=wbNew

'Delete Sourcebook
wbSource.Close False
Kill KillFile

sFile = Dir()
Loop

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set wbSource = Nothing
End Sub

Private Function FileFolderExists(strPath As String) As Boolean
    If Not Dir(strPath, vbDirectory) = vbNullString Then FileFolderExists = True
End Function

Disclaimer: This is my first attempt at anything like this. I cannot speak to the efficiency of this in comparison to what a more experienced coder may be able to provide.

Answer 2

I suggest using the FileSystemObject for path and file references and file move. Use ThisWorkbook.Path as the base for your relative paths (based on the Dashboard workbook location as per the OP)

Sub Demo()
    Dim fso As FileSystemObject
    Dim fldBase As Folder
    Dim fldNew As Folder
    Dim fldArchived As Folder
    Dim fWb As File
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim nm As Name
    Dim rng As Range
    Dim wsDashboard As Worksheet
    Dim OldCalc As XlCalculation

    Const NAMED_RANGE = "export_data"

    On Error GoTo EH:

    Application.ScreenUpdating = False
    OldCalc = Application.Calculation
    Application.Calculation = xlCalculationManual

    ' Set reference to data destination sheet
    Set wsDashboard = ThisWorkbook.Worksheets("ExportData")  '<-- adjust to your ws name in Dashboard

    Set fso = New FileSystemObject
    Set fldBase = fso.GetFolder(ThisWorkbook.Path)

    'Check if \New and \Archive exist
    If Not fso.FolderExists(ThisWorkbook.Path & "\New") Then Exit Sub
    If Not fso.FolderExists(ThisWorkbook.Path & "\Archived") Then Exit Sub

    Set fldNew = fso.GetFolder(ThisWorkbook.Path & "\New")
    Set fldArchived = fso.GetFolder(ThisWorkbook.Path & "\Archived")

    For Each fWb In fldNew.Files
        If fWb.Name Like "*.xls*" Then
            ' Open File
            Set wb = Application.Workbooks.Open(Filename:=fWb.Path, ReadOnly:=True)
            Set nm = wb.Names(NAMED_RANGE)
            Set rng = nm.RefersToRange

            ' Copy Data
            With wsDashboard
                .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(rng.Rows.Count, rng.Columns.Count) = rng.Value
            End With

            ' Close File
            wb.Close SaveChanges:=False

            ' Move File
            fso.MoveFile Source:=fWb.Path, Destination:=fldArchived.Path & "\" & fWb.Name

        End If

    Next
CleanUp:
    Application.ScreenUpdating = True
    Application.Calculation = OldCalc
Exit Sub
EH:
    Stop ' <--- For debug purposes
    Resume CleanUp
End Sub

Don't forget to add a reference to the FileSystemObject, or convert to late binding as shown here -