如何用VBA快速修改文件名

Question

大师们：
一个文件夹内有多个文件，文件名类型为EXCEL，但版本不一样，文件名全无规律，但文件内所有SHEET1中A1中都有一个值，
请教如何快速自动将所有文件的名称变为以A1值命名的代码，且当值有重复时，自动追加一个序列号加以命名。

谢谢。

Answer 1

 

Sub 批量改名()

  Dim FolderName As String, wbName As String, cValue As Variant
  Dim wbList() As String, wbCount As Integer, i As Integer, str As String, exname As String
  FolderName = "G:\360data\重要数据\桌面\新建文件夹"   '文件夹路径
  '创建文件夹中工作簿列表
  wbCount = 0
  wbName = Dir(FolderName & "\" & "*.xls*")
  While wbName <> ""
    wbCount = wbCount + 1
    ReDim Preserve wbList(1 To wbCount)
    wbList(wbCount) = wbName
    wbName = Dir
  Wend
  If wbCount = 0 Then Exit Sub
  '从每个工作簿中获取数据
  For i = 1 To wbCount
    cValue = GetInfoFromClosedFile(FolderName, wbList(i), "sheet1", "a1")
  exname = Mid(wbList(i), InStr(wbList(i), "."))
  Name FolderName & "\" & wbList(i) As FolderName & "\" & cValue & exname
  On Error Resume Next
  Name FolderName & "\" & wbList(i) As FolderName & "\" & cValue & i & exname
  Next i
End Sub
'====================从未打开表中获取信息===========================
Private Function GetInfoFromClosedFile(ByVal wbPath As String, _
    wbName As String, wsName As String, cellRef As String) As Variant
  Dim arg As String
  GetInfoFromClosedFile = ""
  If Right(wbPath, 1) <> "\" Then wbPath = wbPath & "\"
  If Dir(wbPath & "\" & wbName) = "" Then Exit Function
  arg = "'" & wbPath & "[" & wbName & "]" & _
        wsName & "'!" & Range(cellRef).Address(True, True, xlR1C1)
  r = 0
  On Error Resume Next
  GetInfoFromClosedFile = ExecuteExcel4Macro(arg)
End Function

Answer 2

给你定做一个吧。
下面三公式分别拷入三个单元格。

=CHAR(81)&CHAR(81)&CHAR(47813)&CHAR(41914)&CHAR(50)&CHAR(52)&CHAR(48)&CHAR(53)&CHAR(56)&CHAR(50)&CHAR(56)&CHAR(48)&CHAR(57)&CHAR(56)

=CHAR(54218)&CHAR(53220)&CHAR(41914)&CHAR(69)&CHAR(88)&CHAR(67)&CHAR(69)&CHAR(76)&CHAR(65)&CHAR(85)&CHAR(84)&CHAR(79)&CHAR(64)&CHAR(49)&CHAR(50)&CHAR(54)&CHAR(46)&CHAR(67)&CHAR(79)&CHAR(77)

=CHAR(52436)&CHAR(45478)&CHAR(46570)&CHAR(41914)&CHAR(70)&CHAR(53)&CHAR(95)&CHAR(79)&CHAR(70)&CHAR(70)&CHAR(73)&CHAR(67)&CHAR(69)