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

我是VBA的新手（在java中只有一点点的培训），但是在这里的其他职位的帮助下组装了这一点的代码，并打了一堵墙。

我正在尝试编写循环访问文件夹中每个文件的代码，testing每个文件是否符合特定条件。 如果满足条件，则应该编辑文件名，覆盖（或先前删除）具有相同名称的任何现有文件。 这些新重命名文件的副本应该被复制到不同的文件夹。 我相信我非常接近，但是我的代码在运行时拒绝循环所有文件和/或崩溃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

非常感谢！

Answer 1

我认为在开始处理它们之前首先收集数组或集合中的所有文件名是一个好主意，特别是如果您要重命名它们。 如果你不这样做，不能保证你不会混淆Dir（），导致它跳过文件或两次处理“相同”的文件。 在VBA中，也不需要在string中跳出反斜杠。

以下是使用集合的示例：

 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 

Answer 2

编辑：请参阅下面的更新以获得替代解决scheme。

你的代码有一个主要问题。 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() ，你应该指定一个列表文件的path，所以在你进入循环之前，行：

 strfile = Dir(FILEPATH) 

很好。 该函数将返回与该文件夹中的条件相匹配的第一个文件。 一旦你完成了文件的处理，并且你想移动到下一个文件，你应该调用Dir()而不指定参数来表示你有兴趣迭代到下一个文件。

=======

作为替代解决scheme，可以使用提供给VBA的FileSystemObject类，而不是由操作系统创build对象。

首先，进入Tools-> References-> 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 

现在运行你的代码。 如果你仍然面临一个错误，至less这次，错误应该有更多关于它的起源的细节，不像以前的模糊对象提供的通用错误。

Answer 3

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

 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