使用VBA循环遍历文件夹，重命名符合特定条件的文件？

Question

我是VBA新手（只有一点Java培训），但在其他帖子的帮助下，组装了这段代码，并遇到了一些问题。

我正在尝试编写代码，以循环遍历文件夹中的每个文件，测试每个文件是否符合某些条件。 如果满足条件，则应编辑文件名，覆盖（或删除之前的）与相同名称的任何现有文件。 然后应将这些新命名的文件的副本复制到另一个文件夹中。 我认为我非常接近，但我的代码拒绝循环遍历所有文件和/或运行时会崩溃Excel。 请帮忙？ :-)

Sub RenameImages()

Const FILEPATH As String = _
"C:\\CurrentPath"
Const NEWPATH As String = _
"C:\\AditionalPath"


Dim strfile As String
Dim freplace As String
Dim fprefix As String
Dim fsuffix As String
Dim propfname As String

Dim FileExistsbol As Boolean

Dim fso As Object
Set fso = VBA.CreateObject("Scripting.FileSystemObject")

strfile = Dir(FILEPATH)

Do While (strfile <> "")
  Debug.Print strfile
  If Mid$(strfile, 4, 1) = "_" Then
    fprefix = Left$(strfile, 3)
    fsuffix = Right$(strfile, 5)
    freplace = "Page"
    propfname = FILEPATH & fprefix & freplace & fsuffix
    FileExistsbol = FileExists(propfname)
      If FileExistsbol Then
      Kill propfname
      End If
    Name FILEPATH & strfile As propfname
    'fso.CopyFile(FILEPATH & propfname, NEWPATH & propfname, True)
  End If

  strfile = Dir(FILEPATH)

Loop

End Sub

如果有帮助的话，文件名以ABC_mm_dd_hh_Page_#.jpg开头，目标是将它们缩短为ABCPage#.jpg。非常感谢！

- Joe K

---

我认为在开始处理文件之前，首先将所有文件名收集到数组或集合中是一个好主意，特别是如果你要重命名它们。如果不这样做，就不能保证你不会混淆Dir()，导致跳过文件或处理“相同”的文件两次。此外，在VBA中，字符串中不需要转义反斜杠。 - Tim Williams

谢谢Tim！我不确定如何在VBA中实现这一点，但是根据我对Java的基本了解，我认为你所说的很有直观意义。如果我无法让我的当前代码工作，我会尝试那个方法。你能否方便地提供创建你所说的数组的帮助？ - Joe K

Answer 1

编辑：请参见下面的更新，以获取另一种解决方案。

你的代码存在一个主要问题。在Loop结束之前的最后一行是：

   ...
   strfile = Dir(FILEPATH)  'This will always return the same filename

Loop
...

以下是您的代码应该如何编写：

   ...
   strfile = Dir()  'This means: get the next file in the same folder

Loop
...

第一次调用Dir()函数时，您应该指定要列出文件的路径。因此，在进入循环之前，应该有以下代码行:

strfile = Dir(FILEPATH)

这个函数很好用。它会返回第一个与文件夹中指定条件匹配的文件。当你处理完当前文件后，想要移动到下一个文件时，应该调用Dir()，而不指定参数来表示你要迭代到下一个文件。

=======

作为替代方案，你可以使用VBA提供的FileSystemObject类，而不是通过操作系统创建对象。

首先，通过“工具”->“引用”->“Microsoft Scripting Runtime”添加“Microsoft Scripting Runtime”库：

如果你没有看到[Microsoft Scripting Runtime]列出来，只需浏览到C:\windows\system32\scrrun.dll即可。

其次，将你的代码更改为以下方式，以利用所引用的库：

以下两行：

Dim fso As Object
Set fso = VBA.CreateObject("Scripting.FileSystemObject")

应该被这一行替换：

Dim fso As New FileSystemObject

现在运行你的代码。如果你仍然遇到错误，这一次错误应该会提供更多关于其来源的详细信息，而不像之前那个模糊对象提供的通用信息。

- Ahmad

---

谢谢Ahmad！ 不幸的是，虽然你所说的有道理，我之前实际上已经尝试过了，但我收到了以下错误消息，并将上述行标记为问题代码： “运行时错误5’： 无效的过程调用或参数” 有什么建议吗？ - Joe K

@JoeK，你在同一行上遇到了这个错误吗？是没有参数的 dir() 吗？ - Ahmad

@JoeK 我已经更新了我的答案。请检查并告诉我。 - Ahmad

Answer 2

我认为在开始处理文件之前，首先将所有文件名收集到一个数组或集合中是一个好主意，特别是如果您要对它们进行重命名。如果不这样做，就无法保证不会混淆Dir()，导致它跳过文件或处理“相同”的文件两次。另外，在VBA中，字符串中没有必要转义反斜杠。

以下是使用集合的示例：

Sub Tester()

    Dim fls, f

    Set fls = GetFiles("D:\Analysis\", "*.xls*")
    For Each f In fls
        Debug.Print f
    Next f

End Sub



Function GetFiles(path As String, Optional pattern As String = "") As Collection
    Dim rv As New Collection, f
    If Right(path, 1) <> "\" Then path = path & "\"
    f = Dir(path & pattern)
    Do While Len(f) > 0
        rv.Add path & f
        f = Dir() 'no parameter
    Loop
    Set GetFiles = rv
End Function

- Tim Williams

---

嗯，好的，我认为我可以理解大部分内容，除了“pattern”变量。你能为我澄清一下吗？我甚至不明白它为什么存在。非常感谢！ - Joe K

Dir()函数需要一个包含要查找项位置的路径的字符串，该字符串可选择包括一个模式（可以使用通配符）来描述您想要列出的文件名/类型。在本例中，我们传递了“*.xls*”，它匹配任何具有扩展名为.xls，.xlsx，.xlsm等的文件名。如果您不为“pattern”传递值，则会返回path位置中的所有文件。 - Tim Williams

非常感谢！我花了一点时间才弄明白，但在您的帮助/建议下，我想我已经让我的代码运行起来了！我相信Ahmad的建议可能也是可行的，但这似乎是“正确”的方法，并且我必须能够将此代码分发给我的同事们，所以谢谢你！~Joe - Joe K

Answer 3

如果有人想知道，这是我的完成代码。感谢Tim和Ahmad的帮助！

Sub RenameImages()

Const FILEPATH As String = "C:\CurrentFilepath\"
Const NEWPATH As String = "C:\NewFilepath\"


Dim strfile As String
Dim freplace As String
Dim fprefix As String
Dim fsuffix As String
Dim propfname As String
Dim fls, f

Set fls = GetFiles(FILEPATH)
For Each f In fls
    Debug.Print f
    strfile = Dir(f)
      If Mid$(strfile, 4, 1) = "_" Then
        fprefix = Left$(strfile, 3)
        fsuffix = Right$(strfile, 5)
        freplace = "Page"
        propfname = FILEPATH & fprefix & freplace & fsuffix
        FileExistsbol = FileExists(propfname)
          If FileExistsbol Then
          Kill propfname
          End If
        Name FILEPATH & strfile As propfname
        'fso.CopyFile(FILEPATH & propfname, NEWPATH & propfname, True)
      End If
Next f
End Sub

Function GetFiles(path As String, Optional pattern As String = "") As Collection
    Dim rv As New Collection, f
    If Right(path, 1) <> "\" Then path = path & "\"
    f = Dir(path & pattern)
    Do While Len(f) > 0
        rv.Add path & f
        f = Dir() 'no parameter
    Loop
    Set GetFiles = rv
End Function

Function FileExists(fullFileName As String) As Boolean
    If fullFileName = "" Then
        FileExists = False
    Else
        FileExists = VBA.Len(VBA.Dir(fullFileName)) > 0
    End If
End Function

- Joe K

---

这很好用。然而，脚本缺少函数FileExists()，一个可工作的示例可以在这里找到。更新：编辑问题以添加缺失的函数代码。 - cssyphus