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

我付了

我试图制作一个循环VBA宏以：

打开名为的文件夹中的第一个文件 New
复制Defined Name单元格区域中的数据行export_data
将其粘贴到我当前的工作簿中，位于的新行A1上Sheet1
关闭而不保存从中导入数据的文件并将其移至Archived文件夹
重复直到文件New夹中没有剩余文件。

我的文件结构如下：

文件New夹中的所有文件都是相同的（名称除外）.xlsm文件。每个Defined Name单元都有一个称为的单元格范围export_data，我需要将其导入到的单行单元格中Dashboard.xlsm。

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

目前，我已经尽最大努力适应了这篇文章中试图获取宏以移动文件的代码：

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

克里斯·尼尔森

我建议使用FileSystemObjectfor路径和文件引用以及文件移动。使用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的引用，或转换为后期绑定，如下所示-

本文收集自互联网，转载请注明来源。

如有侵权，请联系 [email protected] 删除。