如何根据Excel中的单元格列表重命名文件夹中的所有图像名称？

网友投稿 249 2024-01-13

如何根据Excel中的单元格列表重命名文件夹中的所有图像名称？

您是否尝试过根据工作表中的单元格列表重命名图像？如果是这样，您是否有任何技巧可以快速处理这项工作，而无需一一重命名？在本文中，我介绍了两个VBA代码以在Excel中快速处理此工作。

重命名文件夹中的所有图像名称

要重命名指定文件夹中的所有图像名称，必须首先在工作表中列出原始名称。

1。按 Alt + F11键 启用 Microsoft Visual Basic应用程序 窗口。

2。点击插页 > 模块并将以下代码粘贴到脚本中。

VBA：获取文件夹的图片名称

Sub PictureNametoExcel() UpdatebyExtendoffice201709027 Dim I As Long Dim xRg As Range Dim xAddress As String Dim xFileName As String Dim xFileDlg As FileDialog Dim xFileDlgItem As Variant On Error Resume Next xAddress = ActiveWindow.RangeSelection.Address Set xRg = Application.InputBox("Select a cell to place name list:", "KuTools For Excel", xAddress, , , , , 8) If xRg Is Nothing Then Exit Sub Application.ScreenUpdating = False Set xRg = xRg(1) xRg.Value = "Picture Name" With xRg.Font .Name = "Arial" .FontStyle = "Bold" .Size = 10 End With xRg.EntireColumn.AutoFit Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker) I = 1 If xFileDlg.Show = -1 Then xFileDlgItem = xFileDlg.SelectedItems.Item(1) xFileName = Dir(xFileDlgItem & "\") Do While xFileName <> "" If InStr(1, xFileName, ".jpg") + InStr(1, xFileName, ".png") + InStr(1, xFileName, ".img") + InStr(1, xFileName, ".gif") + InStr(1, xFileName, ".ioc") + InStr(1, xFileName, ".bmp") > 0 Then xRg.Offset(I).Value = xFileDlgItem & "\" & xFileName I = I + 1 End If xFileName = Dir Loop End If Application.ScreenUpdating = True End Sub

Copy

3。按 F5

键运行代码，并弹出一个对话框，提醒您选择一个单元格以输出名称列表。看截图：

4。点击 OK

并选择需要在当前工作表中列出其图片名称的指定文件夹。看截图：

5。点击 OK。图片名称已在活动工作表中列出。

然后，您可以重命名图片。

1。按 Alt + F11键 启用 Microsoft Visual Basic应用程序 窗口。

2。点击插页 > 模块并将以下代码粘贴到脚本中。

VBA：获取重命名图片

Sub RenameFile() UpdatebyExtendoffice20170927 Dim I As Long Dim xLastRow As Long Dim xAddress As String Dim xRgS, xRgD As Range Dim xNumLeft, xNumRight As Long Dim xOldName, xNewName As String On Error Resume Next xAddress = ActiveWindow.RangeSelection.Address Set xRgS = Application.InputBox("Select Original Names(Single Column):", "KuTools For Excel", xAddress, , , , , 8) If xRgS Is Nothing Then Exit Sub Set xRgD = Application.InputBox("Select New Names(Single Column):", "KuTools For Excel", , , , , , 8) If xRgD Is Nothing Then Exit Sub Application.ScreenUpdating = False xLastRow = xRgS.Rows.Count Set xRgS = xRgS(1) Set xRgD = xRgD(1) For I = 1 To xLastRow xOldName = xRgS.Offset(I - 1).Value xNumLeft = InStrRev(xOldName, "\") xNumRight = InStrRev(xOldName, ".") xNewName = xRgD.Offset(I - 1).Value If xNewName <> "" Then xNewName = Left(xOldName, xNumLeft) & xNewName & Mid(xOldName, xNumRight) Name xOldName As xNewName End If Next MsgBox "Congratulations! You have successfully renamed all the files", vbInformation, "KuTools For Excel" Application.ScreenUpdating = True End Sub

Copy

3。按 F5