重命名文件夹中的所有工作簿

我正在尝试重命名文件夹中的所有工作簿，基于每个文件中的单元格的值（基本上报告date）。 xls文件从互联网上保存在一个文件夹中。 我写了下面的代码，但它不工作… workbooks.open失败和wb.name似乎无法正常工作。

Sub openrenamebook() Dim FileExtension As String, FilesInFolder As String Dim FolderPath As String Dim wb As Workbook FileExtension = "*xls" FolderPath = "N:\MyFolder\" FilesInFolder = Dir(FolderPath & FileExtension) Do While FilesInFolder <> "" Set wb = Workbooks.Open(Filename:=FolderPath & FilesInFolder, ReadOnly:=False) wb.Name = Mid(wb.Sheets(1).Cells(1, 2).Value, 38, 2) wb.Close True FilesInFolder = Dir Set wb = Nothing Loop End Sub 

Answer 1

您不能通过更改工作簿名称属性来重命名文件。 但是你可以使用FileSystemObject。

此代码的工作需要对Microsoft Scripting Runtime的引用。

我无法完全testing，因为我不知道在工作表中指定了哪些文件path。 它假定他们是有效的

 Sub Test() Dim FSO As New FileSystemObject Dim FileItem As File Dim wb As Workbook Dim strRenameValue As String FolderPath = "N:\MyFolder\" 'Loop Files For Each FileItem In FSO.GetFolder(FolderPath).Files Set wb = Workbooks.Open(FileItem.Path) 'Get The Value With Which To Rename The Workbook strRenameValue = Mid(wb.Sheets(1).Cells(1, 2).Value, 38, 2) 'You shouldn't need to save? wb.Close False 'Now That The File Is Closed, Rename It FileItem.Name = strRenameValue Set wb = Nothing Next FileItem End Sub 

Answer 2

既然你打算重新命名这些文件，我build议你在重命名这些文件之前把所有的名字加载到一个数组中，以便从Dir获得连贯的值。
我使用以下函数来做到这一点：

 Function GetFileList(FileSpec As String) As Variant ' Returns an array of filenames that match FileSpec ' If no matching files are found, it returns False Dim FileArray() As Variant Dim FileCount As Integer Dim FileName As String On Error GoTo NoFilesFound FileCount = 0 FileName = Dir(FileSpec) If FileName = "" Then GoTo NoFilesFound 'Loop until no more matching files are found Do While FileName <> "" FileCount = FileCount + 1 ReDim Preserve FileArray(1 To FileCount) FileArray(FileCount) = FileName FileName = Dir() Loop GetFileList = FileArray Exit Function ' Error handler NoFilesFound: GetFileList = False End Function 

Answer 3

这个版本使用单独的速度实例（我考虑使用ADO）。

也确保只有Excel文件打开，新的文件名是有效的（我假设你有一个有效的后缀文件types，即在您的单元格名称.xlsx ）

 Sub openrenamebook() Dim xlApp As Excel.Application Dim FileExtension As String Dim FilesInFolder As String Dim FolderPath As String Dim strRenameValue As String Dim wb As Workbook Set xlApp = New Excel.Application With xlApp .Visible = False .ScreenUpdating = False .DisplayAlerts = False End With FileExtension = "*.xls*" FolderPath = "c:\temp\" FilesInFolder = Dir(FolderPath & FileExtension) Do While Len(FilesInFolder) > 0 Set wb = xlApp.Workbooks.Open(FolderPath & FilesInFolder) On Error Resume Next strRenameValue = Mid$(wb.Sheets(1).Cells(1, 2).Value, 38, 2) On Error GoTo 0 wb.Close False If Len(strRenameValue) > 0 Then Name FolderPath & FilesInFolder As FolderPath & strRenameValue Set wb = Nothing FilesInFolder = Dir Loop xlApp.Quit Set xlApp = Nothing End Sub