Private Sub Option1_Click()
Dim myStr As String

'通過在單元格中輸入項目序號,目前采用的InputBox方式指定的，也可通過此方式。二者取其一。
'myStr = Sheets(“Sheet1”).Range(“D21”).Text
 '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
 '通過InputBox輸入項目序號Start
 ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
 myStr = InputBox("請輸入項目序號，序號要為阿拉伯數(shù)字。格式一定要正確！格式如" & Chr(34) & "2項目" & Chr(34))
 '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
 '通過InputBox輸入項目序號End
 '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
 Dim endNum As Integer 'MID函數(shù)截取結束位數(shù)
 endNum = InStrRev(myStr, "項")
 myStr = Mid(myStr, 1, endNum - 1)
 'MsgBox myStr
 Dim CChinesStr As String
 CChineseStr = CChinese(myStr) '將阿拉伯數(shù)字轉為漢字
 '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\匯報\成績"
 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 '正則表達式對象
  Dim mMatches As Object '匹配字符串集合對象
  Dim mMatch As Object '匹配字符串
  Set mRegExp = CreateObject("Vbscript.Regexp")
  With mRegExp
   .Global = True    'True表示匹配所有, False表示僅匹配第一個符合項
   .IgnoreCase = True    'True表示不區(qū)分大小寫, False表示區(qū)分大小寫
   '.Pattern = "([0-9])?[.]([0-9])+|([0-9])+" '匹配字符模式
   '.Pattern = "((([0-9]+)?)|(([一二三四五六七八九十]+)?))項目(([一二三四五六七八九十]+)?)|([0-9])?" '匹配字符模式
   '.Pattern = "(項目(二百三十四)+)|(((234)?|(二百三十四)?)項目(234)?)" '匹配字符模式
   '.Pattern = "(((" & "+)?)|(([一二三四五六七八九十]+)?))項目(([一二三四五六七八九十]+)?)|([0-9])?" '匹配字符模式
   .Pattern = "(項目(" & CChineseStr & ")+)|(((" & myStr & ")?|(" & CChineseStr & ")?)項目(" & myStr & ")?)" '匹配字符模式
  
   'Set mMatches = .Execute(Sheets("上報").Range("D21").Text) '執(zhí)行正則查找，返回所有匹配結果的集合，若未找到，則為空
   
   Set mMatches = .Execute(file) '執(zhí)行正則查找，返回所有匹配結果的集合，若未找到，則為空
   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 & "\目標文件" & myStr '復制操作
   End If
   
  Next
  
  End With
  'MsgBox fileNameArray
 
  Set mRegExp = Nothing
  Set mMatches = Nothing
 
 Next
 Set fso = Nothing
 Set folder = Nothing
 ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
 '遍歷路徑下的文件End
 ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
 MsgBox "操作完成"

End Sub
'將阿拉伯數(shù)字轉為漢字
Private Function CChinese(StrEng As String) As String
'驗證數(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 = " 萬億兆"
'轉換為表示數(shù)值的字符串
StrEng = CStr(CDec(StrEng))
'記錄數(shù)字的長度
intLen = Len(StrEng)
'轉換為漢字
For intCounter = 1 To intLen
'返回數(shù)字對應的漢字
strTempCh = Mid(strEng2Ch, Mid(StrEng, intCounter, 1) + 1, 1)
'若某位是零
If strTempCh = “零” And intLen <> 1 Then
'若后一個也是零，或零出現(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
'對于出現(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
'組成漢字表達式
strCh = strCh & Trim(strTempCh)
Next
CChinese = strCh
End Function

Private Sub commandButton1_Click()

'聲明文件夾名和路徑
Dim FileName, Path As String, EmptySheet As String
'Path = “D:\上報”
Path = InputBox(“請輸入” & Chr(34) & “成績” & Chr(34) & “文件夾的路徑，格式如” & Chr(34) & “D:\成績” & Chr(34))
FileName = Path & “\上學期”
EmptySheet = Path & “\學期初始化”
'MsgBox FileName
If Dir(FileName, vbDirectory) <> “” Then
'MsgBox “文件夾存在”
'獲取系統(tǒng)當前時間
'Dim dd As Date
'dd = Now
'MsgBox Format(dd, “yyyymm”)
Dim myTime As String
myTime = InputBox(“請輸入當前時間，格式如” & Chr(34) & “201811” & Chr(34))
If myTime = “” Then
MsgBox “當前時間不能為空！否則不能重命名當期文件夾”
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
'復制空表到當期
Set Fso = CreateObject(“Scripting.FileSystemObject”)
'拷貝文件夾
Fso.copyfolder EmptySheet, FileName
'Fso.copyfile EmptySheet&“c:*.*”, “d:” '拷貝文件
'FileSystemObject.copyfolder EmptySheet, FileName, 1
MsgBox (“操作成功！”)
End Sub