將"E:\my\彙報\成績"路徑下原始檔中的“1專案”，“一專案”等檔案複製到目標檔案下。以下為實現方式。

Private Sub Option1_Click()
      Dim myStr As String
      '通過在單元格中輸入專案序號,目前採用的InputBox方式指定的，也可通過此方式。二者取其一。
      'myStr = Sheets("Sheet1").Range("D21").Text
    
      '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
      '通過InputBox輸入專案序號Start
      ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
      myStr = InputBox("請輸入專案序號，序號要為阿拉伯數字。格式一定要正確！格式如" & Chr(34) & "2專案" & Chr(34))
      '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
      '通過InputBox輸入專案序號End
      '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
      Dim endNum As Integer     'MID函式擷取結束位數
      endNum = InStrRev(myStr, "項")
      myStr = Mid(myStr, 1, endNum - 1)
      'MsgBox myStr
      Dim CChinesStr As String
      CChineseStr = CChinese(myStr) '將阿拉伯數字轉為漢字
      '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") '建立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表示不區分大小寫, False表示區分大小寫
                     '.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)     '執行正則查詢，返回所有匹配結果的集合，若未找到，則為空
                     
                     Set mMatches = .Execute(file)     '執行正則查詢，返回所有匹配結果的集合，若未找到，則為空
                     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
'將阿拉伯數字轉為漢字
Private Function CChinese(StrEng As String) As String
'驗證資料
If Not IsNumeric(StrEng) Then
If Trim(StrEng) <> "" Then MsgBox "無效的數字"
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 = " 萬億兆"
'轉換為表示數值的字串
StrEng = CStr(CDec(StrEng))
'記錄數字的長度
intLen = Len(StrEng)
'轉換為漢字
For intCounter = 1 To intLen
'返回數字對應的漢字
strTempCh = Mid(strEng2Ch, Mid(StrEng, intCounter, 1) + 1, 1)
'若某位是零
If strTempCh = "零" And intLen <> 1 Then
'若後一個也是零，或零出現在倒數第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
'對於出現在倒數第1、5、9、13等位的數字
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