Private Sub Option1_Click()
Dim myStr As String

'通過在單元格中輸入項(xiàng)目序號(hào),目前采用的InputBox方式指定的，也可通過此方式。二者取其一。
'myStr = Sheets(“Sheet1”).Range(“D21”).Text
 '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
 '通過InputBox輸入項(xiàng)目序號(hào)Start
 ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
 myStr = InputBox("請(qǐng)輸入項(xiàng)目序號(hào)，序號(hào)要為阿拉伯?dāng)?shù)字。格式一定要正確！格式如" & Chr(34) & "2項(xiàng)目" & Chr(34))
 '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
 '通過InputBox輸入項(xiàng)目序號(hào)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)\成績(jī)"
 Set fso = CreateObject("scripting.filesystemobject") '創(chuàng)建FSO對(duì)象
 Set folder = fso.getfolder(basePath & "\源文件")
 For Each file In folder.Files '遍歷根文件夾下的文件
 'fileNameArray = fileNameArray & file & "|"
  Dim mRegExp As Object '正則表達(dá)式對(duì)象
  Dim mMatches As Object '匹配字符串集合對(duì)象
  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) Then
If Trim(StrEng) <> “” Then MsgBox “無效的數(shù)字”
CChinese = “”
Exit Function
End If
'定義變量
Dim intLen As Integer, intCounter As Integer
Dim strCh As String, strTempCh As String
Dim strSeqCh1 As String, strSeqCh2 As String
Dim 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ù)字對(duì)應(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 = “”
Else
strTempCh = strTempCh & Trim(Mid(strSeqCh1, intLen - intCounter + 1, 1))
End If
'對(duì)于出現(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)
Next
CChinese = strCh
End Function

Private Sub commandButton1_Click()

'聲明文件夾名和路徑
Dim FileName, Path As String, EmptySheet As String
'Path = “D:\上報(bào)”
Path = InputBox(“請(qǐng)輸入” & Chr(34) & “成績(jī)” & Chr(34) & “文件夾的路徑，格式如” & Chr(34) & “D:\成績(jī)” & Chr(34))
FileName = Path & “\上學(xué)期”
EmptySheet = Path & “\學(xué)期初始化”
'MsgBox FileName
If Dir(FileName, vbDirectory) <> “” Then
'MsgBox “文件夾存在”
'獲取系統(tǒng)當(dāng)前時(shí)間
'Dim dd As Date
'dd = Now
'MsgBox Format(dd, “yyyymm”)
Dim myTime As String
myTime = InputBox(“請(qǐng)輸入當(dāng)前時(shí)間，格式如” & Chr(34) & “201811” & Chr(34))
If myTime = “” Then
MsgBox “當(dāng)前時(shí)間不能為空！否則不能重命名當(dāng)期文件夾”
Else:
Name FileName As Path & “” & myTime
End If
End 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, 1
MsgBox (“操作成功！”)
End Sub