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

Posted 2023-02-23

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

【英文标题】：Loop VBA macro to open files in a folder, import row, then move to another folder using relative paths

【发布时间】：2018-11-26 03:25:45

【问题描述】：

我正在尝试制作一个循环 VBA 宏来：

在名为New 的文件夹中打开第一个文件 在Defined Name单元格范围export_data中复制数据行 将其粘贴到我当前的工作簿中，在A1Sheet1 上的新行中 关闭而不保存从中导入数据的文件并将其移动到Archived文件夹 重复直到New 文件夹中没有文件为止。

我的文件结构如下：

New 文件夹中的所有文件都是相同的（名称除外）.xlsm 文件。每个都有一个名为export_data 的Defined Name 单元格范围，其中包含我需要导入到我的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

【问题讨论】：

您可以执行两次Save As 调用（在进行任何更改之前调用archive，在应用更改后调用new），然后在完成后调用delete 文件。根据需要进行修改以获取您的relative file path。

这是个好主意，但这会导致文件再次保存，我宁愿避免再次保存，以防任何数据被更改。我可能听起来很谨慎，但我想避免任何潜在的数据丢失。

我没有考虑过这种方式，谢谢。我会尝试一下，但是您将如何使用相对文件夹路径而不是绝对路径？

非常感谢您。我希望我已经达到了这样的水平：这是练习而不是沮丧的练习:)。

【参考方案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 的引用，或者转换为后期绑定as shown here -

【讨论】：

太棒了，我已经放弃了 FSO 方法，却没有意识到它没有运行是因为我的编码不好，而是因为我没有启用 Microsoft Script Runtime，如 @987654322 中所述@

再次感谢您的帮助！我是否遗漏了什么，或者该链接是否也描述了您所说的后期绑定的转换？

不，它没有。更改为更好的链接

太棒了，谢谢！从中学到了很多。祝你有美好的一天！

@chrisneilsen 对于on error goto 有什么特别的原因吗？在这里使用那段代码时，我似乎无情地感到羞耻，哈哈。保存这个解决方案，def 比我的尝试更好

【参考方案2】：

你的挫败感暂时变成了我的挫败感，但唉，经过测试和工作：

这将：

按您指定的方式循环浏览每个文件 将未更改的副本保存在RelativePath > Archived 添加代码来做你想做的事（这里，添加工作表） 将更新后的副本保存在RelativePath > New 删除原文件

SaveAs 文件路径是相对的，如您所问。但是，如果您移动包含原始 excel 的文件夹，则必须更新变量 RelativePath，但无需修改其他任何内容。为了使这完全动态化，您需要找到一种方法将路径动态分配给RelativePath（而不是文件对话？）

如果您正在打开的工作簿所在的目录中没有“存档”或“新建”文件夹，则会出错。

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

免责声明：这是我第一次尝试这样的事情。与更有经验的编码人员可能能够提供的相比，我无法说出这种效率。

【讨论】：

我会去测试它，我想我在某处看到有一种方法可以找到当前工作簿的当前路径，这可能是一种动态设置相对路径的方法。我会进一步调查，但这已经是向前迈出的一大步，感谢您迄今为止所付出的时间和努力。

但是，如果我对编码的有限理解给了我 2 美分，那不是用于导出数据的打开文件的 wbSource.Path 吗？不能在宏的开头调用它来设置Dashboard 工作簿中的RelativePath 变量吗？使用Application.ActiveWorkbook.Pathlink