vba選擇文件（正則、字典等綜合應用）

Option Explicit


Sub test()
    Dim path, dict, item, sht, i, yjh, dir
    path = GetFolder()
    If path = "" Then Exit Sub
    
    Set dict = GetFilesDict(path)
    dir = GetDeskTopTimeDir()
    
    Set sht = ActiveSheet
    sht.Range("b2:b" & sht.UsedRange.Rows.Count).Clear
    For i = 2 To sht.UsedRange.Rows.Count
        yjh = sht.Cells(i, 1)
        If dict.exists(yjh) Then
            FileCopy dict(yjh), dir & "\" & Mid(dict(yjh), InStrRev(dict(yjh), "\") + 1)
            sht.Cells(i, "b") = "ok"
            
        Else
            sht.Cells(i, "b") = "failure"
        End If
    
    Next
    
    Shell "explorer " & dir, vbNormalFocus
    
    
    ' For Each item In dict
    '     Debug.Print item & "--" & Mid(dict(item), InStrRev(dict(item), "\") + 1)
    ' Next

End Sub

Function GetDeskTopTimeDir()
    Dim sj, oWShell, desktopPath, fullpath
    sj = Format(Now(), "yyyyMMdd_hhmmss")
    Set oWShell = CreateObject("WScript.Shell")
    With oWShell
        desktopPath = .specialfolders("Desktop")
    End With
    fullpath = desktopPath & "\" & sj
    If dir(fullpath) = "" Then
        MkDir fullpath
    End If
    set oWShell = nothing
    GetDeskTopTimeDir = fullpath

End Function


'返回選擇的目錄（單個）
Function GetFolder() As String
    Dim fdo
    Set fdo = Excel.Application.FileDialog(msoFileDialogFolderPicker)
    With fdo
        .Title = "請選擇賬單文件夾"
       .Show
       If .SelectedItems.Count = 1 Then
          GetFolder = .SelectedItems(1)
          Set fdo = Nothing
          Exit Function
       End If
    End With
    Set fdo = Nothing
    GetFolder = ""
End Function

Function GetFilesDict(path) 
    Dim dict, filename
    Set dict = CreateObject("Scripting.Dictionary")
    
    filename = dir(path & "\*.*")
    Do While filename <> ""
        dict(GetYjzh(filename)) = path & "\" & filename
        filename = dir()
    Loop
        
    Set GetFilesDict = dict
    Exit Function
End Function


Function GetYjzh(str)
    Dim reg, mc, m
    Set reg = CreateObject("vbscript.regexp")
    reg.Pattern = "_(\d{10})-"
    reg.Global = True
    Set mc = reg.Execute(str)
    For Each m In mc
        GetYjzh = m.submatches.item(0)
        Exit Function
    Next

End Function