Question

我正在尝试根据每个文件中单元格的值重命名文件夹中的所有工作簿（基本上报告日期）。 xls文件从Internet保存在文件夹中。我编写了下面的代码，但它没有工作... 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。

我无法完全测试，因为我不知道您的工作表中指定了哪些文件路径。它假定它们是有效的

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

由于您打算重命名文件，我建议您在重命名文件之前首先将所有名称加载到数组中，以便从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文件并且新文件名有效（我假设您有一个有效的后缀文件类型，即单元名称中的 .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

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

3 个答案: