Set FSO = CreateObject("Scripting.FileSystemObject")
For Each File in FSO.GetFolder(".").Files
   If Lcase(Right(File.Name,4)) = ".xls" Then
      ReDim Preserve ar(i)
      ar(i) = File.Path :i = i + 1
   End if
Next
For i = 0 to UBound(ar) :RenMyFile ar(i) :Next
MsgBox "OK"

Sub RenMyFile(fPath)
   Set oExcel = CreateObject("Excel.Application")
   oExcel.Visible = False
   oExcel.WorkBooks.Open(fPath)
   oExcel.WorkSheets(1).Activate
   Str = Mid(oExcel.Cells(9,1).Value,2,5) & " " & _
   oExcel.Cells(19,1).Value & " " & _
   Mid(oExcel.Cells(1,4).Value,10)
   oExcel.Quit
   Set oExcel = Nothing
   NewFileName = Replace(Str,"/","") & ".xls"
   If Not FSO.FileExists(NewFileName) Then
      FSO.GetFile(fPath).Name = NewFileName
   End If
End Sub
复制代码