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