Question

我正在尝试将循环VBA宏设置为：

在名为New
复制Defined Name单元格范围export_data
将A1

Sheet1

关闭而不保存导入数据的文件并将其移至Archived文件夹
重复，直到New文件夹中没有文件。

我的文件结构如下：

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

我希望宏能够使用Dashboard.xlsm和New文件夹的相对路径，因为它允许我将整个文件集移动到任何地方并仍然可以工作。

目前我已经尽可能地调整代码from this post试图让宏移动文件：

Archived

Answer 1

你的挫折感在一段时间内成了我的挫败感，但唉，经过测试和工作：

这将：

按照您的指定循环浏览每个文件
在RelativePath＆gt;中保存未更改的副本Archived
添加代码以执行您想要执行的操作（此处为“添加工作表”）
将更新后的副本保存在RelativePath＆gt; 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

免责声明：这是我第一次尝试这样的事情。与经验丰富的编码员可能提供的内容相比，我无法谈及这种效率。

Answer 2

我建议使用FileSystemObject进行路径和文件引用以及文件移动。使用ThisWorkbook.Path作为相对路径的基础（根据OP的Dashboard工作簿位置）

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 -

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

2 个答案: