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

我是VBA新手（只接受过一点java方面的培训），但在这里的其他帖子的帮助下汇编了这段代码，我遇到了麻烦

我试图编写代码，循环遍历文件夹中的每个文件，测试每个文件是否符合某些标准。如果符合条件，则应编辑文件名，覆盖（或删除之前）具有相同名称的任何现有文件。然后，应将这些新重命名文件的副本复制到其他文件夹。我相信我已经非常接近了，但我的代码拒绝在所有文件中循环，并且/或者在运行Excel时崩溃。请帮忙？：-）

子重命名图像（）
常量文件路径作为字符串=_
“C:\\CurrentPath”
常量NEWPATH作为字符串=_
“C:\\AditionalPath”
作为字符串的Dim strfile
把某处弄成细绳
作为字符串的Dim fprefix
作为字符串的Dim fsuffix
作为字符串的Dim propfname
Dim FileExistsbol为布尔值
作为对象的Dim fso
设置fso=VBA.CreateObject（“Scripting.FileSystemObject”）
strfile=Dir（文件路径）
Do While（strfile“”）
调试。打印strfile
如果Mid$（strfile，4，1）=“u”，则
fprefix=左$（strfile，3）
fsuffix=Right$（strfile，5）
freplace=“第页”
propfname=FILEPATH&fprefix&freplace&fsuffix
FileExistsbol=FileExists（propfname）
如果文件existsbol，则
杀死专有名称
如果结束
将文件路径和strfile命名为propfname
'fso.CopyFile（FILEPATH&propfname，NEWPATH&propfname，True）
如果结束
strfile=Dir（文件路径）
环
端接头

如果有用的话，文件名以ABC_mm_dd_hh_Page_35;.jpg开头，目标是将它们缩减为ABCPage#.jpg

---

非常感谢

编辑：有关替代解决方案，请参见下面的更新

您的代码有一个主要问题。。

循环

结束前的最后一行是

   ...
   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脚本运行时添加“Microsoft脚本运行时”库

如果您没有看到列出的[Microsoft脚本运行时]，只需浏览到

C:\windows\system32\scrrun.dll

，也可以这样做

其次，更改代码以使用引用的库，如下所示：

以下两行：

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

应替换为这一行：

Dim fso As New FileSystemObject

---

现在运行代码。如果您仍然面临错误，至少这一次，错误应该有关于其来源的更多详细信息，这与以前的vague对象提供的一般性错误不同。

我认为最好先收集数组或集合中的所有文件名，然后再开始处理这些文件名，特别是当您要重命名它们时。如果不这样做，则无法保证不会混淆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

子测试仪（）
模糊fls，f
设置fls=GetFiles（“D:\Analysis\，“*.xls*”）
对于fls中的每个f
调试。打印f
下一个f
端接头
函数GetFiles（路径为String，可选模式为String=“”）作为集合
将rv作为新系列，f
如果正确（路径，1）“\”则路径=路径&“\”
f=Dir（路径和模式）
当Len（f）>0时执行
rv.添加路径和f
f=Dir（）'无参数
环
设置GetFiles=rv
端函数

如果有人想知道，这是我完成的代码。感谢蒂姆和艾哈迈德的帮助

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

子重命名图像（）
常量文件路径为String=“C:\CurrentFilepath\”
Const NEWPATH As String=“C:\NewFilepath\”
作为字符串的Dim strfile
把某处弄成细绳
作为字符串的Dim fprefix
作为字符串的Dim fsuffix
作为字符串的Dim propfname
模糊fls，f
设置fls=GetFiles（文件路径）
对于fls中的每个f
调试。打印f
strfile=Dir（f）
如果Mid$（strfile，4，1）=“u”，则
fprefix=左$（strfile，3）
fsuffix=Right$（strfile，5）
freplace=“第页”
propfname=FILEPATH&fprefix&freplace&fsuffix
FileExistsbol=FileExists（propfname）
如果文件existsbol，则
杀死专有名称
如果结束
将文件路径和strfile命名为propfname
'fso.CopyFile（FILEPATH&propfname，NEWPATH&propfname，True）
如果结束
下一个f
端接头
函数GetFiles（路径为String，可选模式为String=“”）作为集合
将rv作为新系列，f
如果正确（路径，1）“\”则路径=路径&“\”
f=Dir（路径和模式）
当Len（f）>0时执行
rv.添加路径和f
f=Dir（）'无参数
环
设置GetFiles=rv
端函数
函数FileExists（fullFileName为字符串）为布尔值
如果fullFileName=“”，则
FileExists=False
其他的
FileExists=VBA.Len（VBA.Dir（fullFileName））>0
如果结束
端函数

我认为最好先收集数组或集合中的所有文件名，然后再开始处理这些文件名，特别是当您要重命名它们时。如果不这样做，则无法保证不会混淆Dir（），导致它跳过文件或两次处理“同一”文件。在VBA中，也不需要在字符串中转义反斜杠。谢谢Tim！我不知道如何在VBA中做到这一点，但我认为基于我对java的最低知识，您所说的是直观的。如果我不能让我当前的代码正常工作，我会尝试这样做。有没有可能你可以轻松公关

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