Question

我正在尝试执行以下操作：

指定文件夹（containsinf * .xlsm文件）
遍历所有文件
打开每个文件，运行宏，关闭并保存文件
转到下一个文件，直到完成所有操作。

下面的代码可以工作，但是循环永远不会结束......就像每次保存刚刚处理过的文件一样，它会显示为要经过的文件列表中的新项目。

我做错了什么？

感谢。

Sub runMe()

    Dim objFSO As Object
        Dim objFolder As Object
        Dim objFile As Object
        Dim MyPath As String
        Dim wb As Workbook
        Dim myDir As String

    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .EnableEvents = False
    End With

    myDir = "\templates"
    Debug.Print ActiveWorkbook.Path
    MyPath = ActiveWorkbook.Path & myDir

    Set objFSO = CreateObject("Scripting.FileSystemObject")

    'Get the folder object associated with the directory
    Set objFolder = objFSO.GetFolder(MyPath)

    'Loop through the Files 

    For Each objFile In objFolder.Files
        If InStr(objFile.Name, "~") = 0 And InStr(objFile.Name, ".xlsm") <> 0 Then
            Set wb = Workbooks.Open(objFile, 3)
            Application.Run "'" & wb.Name & "'!doMacro"
            wb.Close SaveChanges:=True
           ' Gets stuck in this loop
           ' WHY DOES IT KEEP LOOPING?
        End If
    Next

    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
        .EnableEvents = True
    End With

End Sub

Answer 1

Sub runMe()
    Dim FSO As New Scripting.FileSystemObject
    Dim File As Scripting.File
    Dim path As String

    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .EnableEvents = False
    End With

    path = ActiveWorkbook.Path & "\templates"

    For Each File In FSO.GetFolder(path).Files
        If InStr(File.Name, "~") = 0 _
           And LCase(FSO.GetExtensionName(File.Name)) = "xlsm" _
        Then
            With Workbooks.Open(File.Path, 3)
                Application.Run "'" & .Name & "'!doMacro"
                .Close SaveChanges:=True
            En With
        End If
    Next

    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
        .EnableEvents = True
    End With
End Sub

根据定义，您的For Each循环不能永远运行，错误必须是其他地方，大概是doMacro所做的。

主观说明：

在您的VBA项目中包含对scrrun.dll的引用。这对于早期绑定（New Scripting.FileSystemObject）非常有用，它可以为这些对象提供代码完成。
GetExtensionName()对于获取文件扩展名非常有用。
删除匈牙利符号，无论如何你都没有使用它。
您不需要For Each的辅助变量。
您可以使用With块替换其他辅助变量（wb）。

Answer 2

通过查看您的评论，我认为问题在于，当您保存文件时，它会以某种方式添加回FSO.GetFolder(path).Files集合迭代。解决此问题的方法是使用文件名构建一个数组，然后执行循环。相关代码如下：

Dim aux As String, Paths as Variant, Path as Variant

For Each File In FSO.GetFolder(path).Files
    If Not File.Name Like "~*" And File.Name Like "*.xlsm" Then
       aux = aux & File.Path & ";"
    End If
Next File

If Len(aux) = 0 Then Exit Sub 'No file matches the criteria
Paths = Split(Left(aux, Len(aux) -1), ";") 'Builds an array with the filenames

For Each Path In Paths
    With Workbooks.Open(Path, 3)
        Application.Run "'" & .Name & "'!doMacro"
        .Close SaveChanges:=True
    End With
Next Path

我构建了一个用“;”分隔的字符串然后使用Split构建一个数组以避免使用索引，ReDim Preserve语句或测试文件名是否为空

Excel VBA迭代文件 - 陷入循环中

2 个答案: