EXCELVBA取税务局下载的文件名中名单与身份证号并配匹单位名称

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