vba - 循环 VBA 宏以打开文件夹中的文件、导入行，然后使用相对路径移动到另一个文件夹

Question

我正在尝试创建一个循环 VBA 宏来:

1. 打开名为 New 的文件夹中的第一个文件
2. 复制Defined Name单元格区域中的数据行export_data
3. 将其粘贴到我当前工作簿中 Sheet1 上 A1 的新行
4. 关闭而不保存从中导入数据的文件，并将其移动到Archived文件夹
5. 重复此操作，直到 New 文件夹中不再有任何文件。

我的文件结构如下:

New 文件夹中的所有文件都是相同的(名称除外).xlsm 文件。每个都有一个名为 export_data 的定义名称单元格范围，其中包含我需要导入到 Dashboard.xlsm 中的单行单元格。

我希望宏使用 New 和 Archived 文件夹的相对路径，因为它允许我将整组文件移动到任何地方并且仍然可以工作。

目前我已经尽可能地适应了代码 from this post试图让宏移动文件:

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

我建议使用FileSystemObject 进行路径和文件引用以及文件移动。使用 ThisWorkbook.Path 作为相对路径的基础(基于 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

不要忘记添加对 FileSystemObject 的引用，或转换为后期绑定(bind) as shown here -