EXCELVBA取税务局下载的文件名中名单与身份证号并配匹单位名称
'打开文件对话框，选定文件夹，得出所有文件名（只有文件名）
Sub PFL() 'return file names under specific folder
'Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row 1).ClearContents
Dim fp, Fname As String, i As Integer, obmapp As Object
Dim dicTemp As Object
Set dicTemp = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
ti = Timer()
With Sheets("源数据")
For i = 2 To .Cells(Rows.Count, 1).End(xlUp).Row
ts = .Cells(i, 4)
If ts <> "" Then
dicTemp(ts) = .Cells(i, 2)
End If
Next i
End With
i = 2
Set obmapp = CreateObject("Shell.Application").BrowseForFolder(0, "请选择目录", 0, ThisWorkbook.Path)
If Not obmapp Is Nothing Then
fp = obmapp.self.Path & "*.*"
Else
MsgBox "你没有选择任何目录"
Exit Sub
End If
Fname = Dir(fp)
Do While Fname <> ""
Cells(i, 1) = Left(Fname, Len(Fname) - 4)
k = InStr(Fname, "【")
j = InStr(Fname, "】_【")
p = InStr(Fname, "】的")
Cells(i, 2) = Mid(Fname, k 1, j - k - 1)
Cells(i, 3).NumberFormatLocal = "@"
d = Mid(Fname, j 3, p - j - 3)
Cells(i, 3) = d
If dicTemp.Exists(d) Then
Cells(i, 4) = dicTemp(d)
Else
Cells(i, 4) = ""
End If
Fname = Dir
i = i 1
Loop
Application.ScreenUpdating = True
MsgBox "提取完成，时间为" & Format(Timer - ti, "00.00秒")
End Sub
