1. 页面布局

在“main”Sheet中按照下面的格式编辑。

2. 实现代码

Private wsMain As Worksheet
Private intIdx As LongPrivate Sub getExcelBookList(strPath As String)Dim fso As ObjectDim objFile As ObjectDim objFolder As ObjectSet fso = CreateObject("Scripting.FileSystemObject")For Each objFolder In fso.GetFolder(strPath).SubFoldersCall getExcelBookList(objFolder.Path)Next objFolderFor Each objFile In fso.GetFolder(strPath).FilesIf Left(objFile.Name, 1) <> "~" ThenwsMain.Cells(intIdx, 3) = strPathwsMain.Cells(intIdx, 4) = objFile.NameintIdx = intIdx + 1End IfNext objFileSet objFile = NothingSet objFolder = NothingSet fso = Nothing
End SubSub list()Set wsMain = ThisWorkbook.Sheets("main")intIdx = 6DoIf wsMain.Cells(intIdx, 3) = "" ThenExit DoEnd IfintIdx = intIdx + 1LoopCall getExcelBookList(wsMain.Cells(2, 3))Set wsMain = Nothing
End SubSub prepare()Dim fso As ObjectDim strExtentName As StringDim strBaseName As StringDim strPrefix As StringDim strSuffix As StringDim strFolderPath As StringDim strOldFileName As StringDim strNewFileName As StringSet fso = CreateObject("Scripting.FileSystemObject")Set wsMain = ThisWorkbook.Sheets("main")strPrefix = wsMain.Cells(3, 3)strSuffix = wsMain.Cells(4, 3)intIdx = 6While wsMain.Cells(intIdx, 3) <> ""If wsMain.Cells(intIdx, 2) = "" ThenstrFolderPath = wsMain.Cells(intIdx, 3)strOldFileName = wsMain.Cells(intIdx, 4)strBaseName = fso.GetBaseName(strFolderPath & "\" & strOldFileName)strExtentName = fso.GetExtensionName(strFolderPath & "\" & strOldFileName)strNewFileName = strPrefix & strBaseName & strSuffix & IIf(strExtentName = "", "", "." & strExtentName)wsMain.Cells(intIdx, 5) = strNewFileNameEnd IfintIdx = intIdx + 1WendSet wsMain = NothingSet fso = Nothing
End SubSub exec()Dim fso As ObjectDim objFile As ObjectDim strFolderPath As StringDim strOldFileName As StringDim strNewFileName As StringSet fso = CreateObject("Scripting.FileSystemObject")Set wsMain = ThisWorkbook.Sheets("main")intIdx = 6While wsMain.Cells(intIdx, 3) <> ""If wsMain.Cells(intIdx, 2) = "" ThenstrFolderPath = wsMain.Cells(intIdx, 3)strOldFileName = wsMain.Cells(intIdx, 4)strNewFileName = wsMain.Cells(intIdx, 5)If strOldFileName <> strNewFileName ThenSet objFile = fso.GetFile(strFolderPath & "\" & strOldFileName)objFile.Name = strNewFileNameSet objFile = NothingEnd IfwsMain.Cells(intIdx, 2) = "Done"End IfintIdx = intIdx + 1WendMsgBox "Done."Set wsMain = NothingSet fso = Nothing
End SubSub clear()Set wsMain = ThisWorkbook.Sheets("main")wsMain.Range("B6", "E" & Rows.Count).ClearContentsSet wsMain = Nothing
End Sub