Private Sub Option1_Click()Dim myStr As String'通過在單元格中輸入項(xiàng)目序號,目前采用的InputBox方式指定的，也可通過此方式。二者取其一。'myStr = Sheets(“Sheet1”).Range(“D21”).Text ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '通過InputBox輸入項(xiàng)目序號Start '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' myStr = InputBox("請輸入項(xiàng)目序號，序號要為阿拉伯?dāng)?shù)字。格式一定要正確！格式如" & Chr(34) & "2項(xiàng)目" & Chr(34)) ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '通過InputBox輸入項(xiàng)目序號End ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Dim endNum As Integer 'MID函數(shù)截取結(jié)束位數(shù) endNum = InStrRev(myStr, "項(xiàng)") myStr = Mid(myStr, 1, endNum - 1) 'MsgBox myStr Dim CChinesStr As String CChineseStr = CChinese(myStr) '將阿拉伯?dāng)?shù)字轉(zhuǎn)為漢字 'MsgBox CChineseStr ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '遍歷路徑下的文件Start ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Dim fso As Object Dim folder As Object Dim subfolder As Object Dim file As Object Dim fileNameArray As String Dim basePath As String basePath = "E:/my/匯報(bào)/成績" Set fso = CreateObject("scripting.filesystemobject") '創(chuàng)建FSO對象 Set folder = fso.getfolder(basePath & "/源文件") For Each file In folder.Files '遍歷根文件夾下的文件 'fileNameArray = fileNameArray & file & "|"  Dim mRegExp As Object '正則表達(dá)式對象  Dim mMatches As Object '匹配字符串集合對象  Dim mMatch As Object '匹配字符串  Set mRegExp = CreateObject("Vbscript.Regexp")  With mRegExp   .Global = True    'True表示匹配所有, False表示僅匹配第一個(gè)符合項(xiàng)   .IgnoreCase = True    'True表示不區(qū)分大小寫, False表示區(qū)分大小寫   '.Pattern = "([0-9])?[.]([0-9])+|([0-9])+" '匹配字符模式   '.Pattern = "((([0-9]+)?)|(([一二三四五六七八九十]+)?))項(xiàng)目(([一二三四五六七八九十]+)?)|([0-9])?" '匹配字符模式   '.Pattern = "(項(xiàng)目(二百三十四)+)|(((234)?|(二百三十四)?)項(xiàng)目(234)?)" '匹配字符模式   '.Pattern = "(((" & "+)?)|(([一二三四五六七八九十]+)?))項(xiàng)目(([一二三四五六七八九十]+)?)|([0-9])?" '匹配字符模式   .Pattern = "(項(xiàng)目(" & CChineseStr & ")+)|(((" & myStr & ")?|(" & CChineseStr & ")?)項(xiàng)目(" & myStr & ")?)" '匹配字符模式     'Set mMatches = .Execute(Sheets("上報(bào)").Range("D21").Text) '執(zhí)行正則查找，返回所有匹配結(jié)果的集合，若未找到，則為空      Set mMatches = .Execute(file) '執(zhí)行正則查找，返回所有匹配結(jié)果的集合，若未找到，則為空   For Each mMatch In mMatches   'SumValueInText = SumValueInText + CDbl(mMatch.Value)   'SumValueInText = SumValueInText & mMatch.Value   If mMatch.Value <> "" Then   'fileNameArray = fileNameArray & mMatch.Value & "_"   fso.copyfile basePath & "/源文件/" & mMatch.Value & ".*", basePath & "/目標(biāo)文件" & myStr '復(fù)制操作   End If     Next    End With  'MsgBox fileNameArray   Set mRegExp = Nothing  Set mMatches = Nothing  Next Set fso = Nothing Set folder = Nothing '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '遍歷路徑下的文件End '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' MsgBox "操作完成"End Sub'將阿拉伯?dāng)?shù)字轉(zhuǎn)為漢字Private Function CChinese(StrEng As String) As String'驗(yàn)證數(shù)據(jù)If Not IsNumeric(StrEng) ThenIf Trim(StrEng) <> “” Then MsgBox “無效的數(shù)字”CChinese = “”Exit FunctionEnd If'定義變量Dim intLen As Integer, intCounter As IntegerDim strCh As String, strTempCh As StringDim strSeqCh1 As String, strSeqCh2 As StringDim strEng2Ch As String'strEng2Ch = “零壹貳叁肆伍陸柒捌玖”strEng2Ch = “零一二三四五六七八九十”'strSeqCh1 = " 拾佰仟 拾佰仟 拾佰仟 拾佰仟"strSeqCh1 = " 十百千 十百千 十百千 十百千"strSeqCh2 = " 萬億兆"'轉(zhuǎn)換為表示數(shù)值的字符串StrEng = CStr(CDec(StrEng))'記錄數(shù)字的長度intLen = Len(StrEng)'轉(zhuǎn)換為漢字For intCounter = 1 To intLen'返回?cái)?shù)字對應(yīng)的漢字strTempCh = Mid(strEng2Ch, Mid(StrEng, intCounter, 1) + 1, 1)'若某位是零If strTempCh = “零” And intLen <> 1 Then'若后一個(gè)也是零，或零出現(xiàn)在倒數(shù)第1、5、9、13等位，則不顯示漢字“零”If Mid(StrEng, intCounter + 1, 1) = “0” Or (intLen - intCounter + 1) Mod 4 = 1 Then strTempCh = “”ElsestrTempCh = strTempCh & Trim(Mid(strSeqCh1, intLen - intCounter + 1, 1))End If'對于出現(xiàn)在倒數(shù)第1、5、9、13等位的數(shù)字If (intLen - intCounter + 1) Mod 4 = 1 Then'添加位" 萬億兆"strTempCh = strTempCh & Trim(Mid(strSeqCh2, (intLen - intCounter) / 4 + 1, 1))End If'組成漢字表達(dá)式strCh = strCh & Trim(strTempCh)NextCChinese = strChEnd Function

Private Sub commandButton1_Click()'聲明文件夾名和路徑Dim FileName, Path As String, EmptySheet As String'Path = “D:/上報(bào)”Path = InputBox(“請輸入” & Chr(34) & “成績” & Chr(34) & “文件夾的路徑，格式如” & Chr(34) & “D:/成績” & Chr(34))FileName = Path & “/上學(xué)期”EmptySheet = Path & “/學(xué)期初始化”'MsgBox FileNameIf Dir(FileName, vbDirectory) <> “” Then'MsgBox “文件夾存在”'獲取系統(tǒng)當(dāng)前時(shí)間'Dim dd As Date'dd = Now'MsgBox Format(dd, “yyyymm”)Dim myTime As StringmyTime = InputBox(“請輸入當(dāng)前時(shí)間，格式如” & Chr(34) & “201811” & Chr(34))If myTime = “” ThenMsgBox “當(dāng)前時(shí)間不能為空！否則不能重命名當(dāng)期文件夾”Else:Name FileName As Path & “” & myTimeEnd IfEnd If'判斷文件夾是否存在If Dir(FileName, vbDirectory) = “” Then'創(chuàng)建文件夾MkDir (FileName)'MsgBox (“創(chuàng)建完畢”)Else: MsgBox (“文件夾已在”)End If'復(fù)制空表到當(dāng)期Set Fso = CreateObject(“Scripting.FileSystemObject”)'拷貝文件夾Fso.copyfolder EmptySheet, FileName'Fso.copyfile EmptySheet&“c:*.*”, “d:” '拷貝文件'FileSystemObject.copyfolder EmptySheet, FileName, 1MsgBox (“操作成功！”)End Sub