excel - 使用 Excel VBA 重命名多个文件

Question

我正在使用这两个代码：

1. Get_Files_Information：从文件夹中提取文件名以进行重命名

Option Explicit

Sub Get_Files_Information()

Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("Sheet1")

Dim fso As New FileSystemObject
Dim fo As Folder
Dim f As File

Set fo = fso.GetFolder(sh.Range("H1").Value)

Dim last_raw As Integer

For Each f In fo.Files
     last_raw = sh.Range("A" & Application.Rows.Count).End(xlUp).Row + 1
     sh.Range("A" & last_raw).Value = f.Name
Next

MsgBox "Done"

End Sub

2. Rename_Files：这段代码是重命名文件

Sub Rename_Files()

Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("Sheet1")

Dim fso As New FileSystemObject
Dim fo As Folder
Dim f As File

Dim new_name As String

Set fo = fso.GetFolder(sh.Range("H1").Value)

For Each f In fo.Files
    new_name = Application.VLookup(f.Name, sh.Range("A:B"), 2, 0)
    f.Name = new_name
Next

MsgBox "Done"

End Sub

当 Get_Files_Information 获取文件名时，结果将带有文件扩展名。我想从文件名中排除文件扩展名，这样重命名就不会因为文件扩展名而卡住。

同样在执行重命名代码时我得到

键入不匹配运行时错误 13。

上new_name = Application.VLookup(f.Name, sh.Range("A:B"), 2, 0)

Excel 宏文件供参考。

https://drive.google.com/open?id=1Zivo3aIn-Id9XtgQu-qpOstL_j7eacjv

标签： excelvba

Answer 1

试试下面的代码。它将检查是否Application.VLookup(f.Name, sh.Range("A:B"), 2, 0)返回错误（可能是由返回错误的公式引起的，如#VALUE）

Sub Rename_Files()

    Dim sh As Worksheet
    Set sh = ThisWorkbook.Sheets("Sheet1")

    Dim fso As New FileSystemObject
    Dim fo As Folder
    Dim f As File

    Dim new_name As String

    Set fo = fso.GetFolder(sh.Range("H1").Value)

    For Each f In fo.Files
        Dim vRes As Variant
        vRes = Application.VLookup(f.Name, sh.Range("A:B"), 2, 0)
        If IsError(vRes) Then
            MsgBox "Cannot rename " & f.Name & " - " & CStr(vRes)
        Else
            new_name = vRes
            f.Name = new_name
        End If
    Next

    MsgBox "Done"

End Sub

该代码还会提示您出了什么问题，因为它会为您提供单元格错误值。对于关于 vlookup 的扩展讨论，我建议看看这篇文章