詳解拖把軟件批量改名步驟「拖把更名器改變文件名稱」

Excel2007以前的格式是.xls，之後的格式是.xlsx。打開單獨的一個Excel文檔，使用“另存為”功能，可以很輕鬆的轉換格式。但是面對幾百個Excel表這樣就太累了，搜索很久，也沒發現一個工具可以直接批量進行格式轉換。

最終發現可以使用VBA來實現批量轉換Excel格式的功能。大家不要被嚇到，VBA我也不懂，代碼是從別人那裡搞到的，現在也只是知道了怎麼使用，但這足夠解決問題了

VBA介紹：

1、VBA是一種編程語言，它依託於Office軟件，不能獨立的運行，通過VBA可以實現各種Office軟件操作的自動化。

2、Visual Basic for Applications(VBA)是Visual Basic的一種宏語言，主要能用來擴展Windows的應用程式功能。使用Excel的VBA開發的Excel文檔，在Excel中運行時需要開啟Excel的宏功能，否則此文檔的VBA自動化功能將被完全屏蔽，文檔的功能無法實現。

執行條件：

1、Office2007及以上版本的Excel

2、Excel啟用宏

功能介紹：

先介紹這兩個工具功能，大家可以根據需要下載。

【xls-To-xlsx.xlsm】

會在所在文件夾目錄中、包括子目錄中，遍歷所有.xls格式的文件，執行“另存為”操作，然後在原文件當前位置另存為一個同名的.xlsx格式的文件。

比如：

執行前【xls-To-xlsx.xlsm】所在的文件夾中有4個.xls格式的文件;

同時包含一個子文件夾，子文件夾中也有4個.xls格式的文件。

執行後，會生成如下(紅色虛線內標註)文件：

【Convert-TO-xlsx.xlsm】

會在所在文件夾目錄中(不包括子目錄)，遍歷所有.xls格式的文件，執行“另存為”操作，然後在當前路徑下生成一個xlsx的文件夾，這個文件夾中放了所有新生成的文件。

比如：

執行前【Convert-TO-xlsx.xlsm】所在的【Convert-TO-xlsx】文件夾中有4個.xls格式的文件

執行後，會生成如下(紅色虛線內標註)文件：

執行方法：

1、下載附件，或者新建一個Excel;

2、啟用宏操作

一般情況下，打開Excel的時候，會彈出如下警告，如果彈出了這個警告，直接啟用就可以了;

如果沒有出現的話，請參考《Excel怎樣設置啟用宏功能》文章

3、編寫執行VBA代碼

這一步新手肯定是不會的，詳細的圖文介紹就參考《Excel VBA 概述》文章。

這裡只作簡單的說明：

(a) 在工作表界面按下組合快捷鍵【Alt+F11】或者【右鍵單擊任意一個工作表標籤，在彈出的右鍵快捷菜單單擊“查看代碼”】進入VBA編輯環境
(b) 如果是下載的我的工具，可以跳過此步驟；如果是新建的Excel，此時在VBA編輯環境中的“代碼窗口”複製粘貼下方 VBA代碼內容【xls-To-xlsx.xlsm】VBA代碼內容 或者《Convert-TO-xlsx.xlsm》VBA代碼內容兩個代碼中的一個
(c) 按下【F5】快捷鍵執行這段代碼或者在菜單中單擊【運行子過程/用戶窗體(F5)】按鈕

PS：需要說明的是，在執行過程中，不要去做其他的操作，不然可能會中斷程序的運行

VBA代碼內容

【xls-To-xlsx.xlsm】VBA代碼內容

'***********訪問當前文件夾目錄下所有子文件夾及文件,
Dim iFile(1 To 100000) As String
Dim count As Integer
Sub xls2xlsx()
 iPath = ThisWorkbook.Path
 On Error Resume Next
 count = 0
 zdir iPath
 For i = 1 To count
 If iFile(i) Like "*.xls" And iFile(i) <> ThisWorkbook.FullName Then '請注意區分目錄下文件後綴.xls大小寫
 MyFile = iFile(i)
 FilePath = Replace(MyFile, ".xls", ".xlsx") '請注意區分目錄下文件後綴.xls大小寫
 If Dir(FilePath, 16) = Empty Then
 Set WBookOther = Workbooks.Open(MyFile)
 Application.ScreenUpdating = False
 ActiveWorkbook.SaveAs Filename:=FilePath, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
 WBookOther.Close SaveChanges:=False '解決不能close 文件問題
 Application.ScreenUpdating = True
 End If
 End If
 Next
End Sub
Sub zdir(p) '訪問當前文件夾下所有子文件夾及文件
 Set fs = CreateObject("scripting.filesystemobject")
 For Each f In fs.GetFolder(p).Files
 If f <> ThisWorkbook.FullName Then count = count + 1: iFile(count) = f
 Next
 For Each m In fs.GetFolder(p).SubFolders
 zdir m
 Next
End Sub

《Convert-TO-xlsx.xlsm》VBA代碼內容

Sub xls2xlsx()
Dim FilePath, MyFile, iPath, Name, OutPath As String
iPath = ThisWorkbook.Path
OutPath = Dir(iPath & "xlsx", vbDirectory)
If OutPath = "" Then
 MkDir (iPath & "xlsx")
End If
MyFile = Dir(iPath & "*.xls")
If MyFile <> "" Then
Do
 On Error Resume Next
 If MyFile = ThisWorkbook.Name Then MyFile = Dir
 Workbooks.Open (iPath & "" & MyFile)
 MyFile = Replace(MyFile, ".xls", ".xlsx")
 Name = "" & MyFile
 FilePath = iPath & "xlsx" & Name
 Application.ScreenUpdating = False
 ActiveWorkbook.SaveAs Filename:=FilePath, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
 Workbooks(MyFile).Close True
 Application.ScreenUpdating = True
 MyFile = Dir
Loop While MyFile <> ""
End If
End Sub

後來有同學提了些問題，最後執行代碼的時候，並沒有達到效果。

先來看下正常的效果，會先彈出一個對話框，然後運行