VBA用字典批量查找社保数据

VBA用字典批量查找社保数据（VLookup功能加强版）

【问题】我们知道社保导出的数据是很多合并的单元格，如果要查找一个数据都要找很久，如果数量多了更多费时，基于以上问题，特用VBA设计一个批量查找的程序。

==本程序是个人原创学习之用==

====程序1====

代码语言：javascript复制

Sub 批量查找社保数据a()
    Dim dic As Object, wb As Workbook
    Set dic = CreateObject("scripting.dictionary")
    Application.ScreenUpdating = False
    ti = Timer
    Set mysht = Sheets("主")
    With Sheets("主")
        LastCol = .Range("a4").End(xlToRight).Column
        arr = .Range(.Cells(4, 1), .Cells(4, LastCol))
        LastRow = .Cells(Rows.Count, 1).End(xlUp).Row
        For dici = 5 To LastRow
            dic(.Cells(dici, 1).Value) = dici
'            Debug.Print dici
        Next dici
        file = .Range("b1")
        file_sht = .Range("D1")
        .Range(.Cells(5, 1), .Cells(LastRow, LastCol)).NumberFormatLocal = "@"
    End With
    Set wb = Workbooks.Open(file)
    With wb.Sheets(file_sht)
        brr = .UsedRange.Value
        For i = 1 To UBound(brr)
            s = .Cells(i, ColumnNum(arr(1, 1)))
            If dic.exists(s) Then
                For j = 2 To UBound(arr, 2)
                    mysht.Cells(dic(s), j) = .Cells(i, ColumnNum(arr(1, j)))
                Next j
            End If
        Next i
    End With
    wb.Close False
        Application.ScreenUpdating = True
    MsgBox "完成！时间为：" & Format(Timer - ti, "0.000秒")
End Sub

用时2.172秒

====程序2====

代码语言：javascript复制

Sub 用字典批量查找数据()
    Dim mydic As Object, obj As Object, main_sht As Worksheet
    Dim Urng As Range
    Dim arr, brr, temp_rr()
    Set mydic = CreateObject("scripting.dictionary")
    Application.ScreenUpdating = False
    ti = Timer
    Set main_sht = Sheets("主")
    With main_sht
        Lcol = .Range("a4").End(xlToRight).Column
        Lrow = .Cells(Rows.Count, 1).End(xlUp).Row
        Set Urng = Union(.Range("b1"), .Range("d1"), .Range("a4").Resize(1, Lcol))
        If Application.CountA(Urng) <> Urng.Count Or Lrow <= 4 Then MsgBox "有单元格的初始数据没设置": Exit Sub
        arr = .Range("a4").Resize(1, Lcol)
        file = .Range("B1")
        file_sht = .Range("D1")
        ReDim temp_arr(1 To UBound(arr, 2))
    End With
    Set obj = GetObject(file)
    With obj.Worksheets(file_sht)
        brr = .UsedRange.Value
        For i = 1 To UBound(brr)
            s = .Cells(i, arr(1, 1))
            If s <> "" Then
                'For j = 1 To UBound(temp_arr)
                mydic(s) = Array(.Cells(i, arr(1, 2)), .Cells(i, arr(1, 3)), .Cells(i, arr(1, 4)), .Cells(i, arr(1, 5)))
                'Next j
                'Debug.Print mydic(s)
            End If
        Next i
    End With
    With Sheets("Sheet2")
        For i = 2 To .Cells(Rows.Count, 1).End(xlUp).Row
            s = .Cells(i, 1)
            If mydic.exists(s) Then
                .Cells(i, 2).Resize(1, Lcol - 1) = mydic(s)
            Else
                .Cells(i, 2).Resize(1, Lcol - 1) = "无"
            End If
        Next i
    End With
    obj.Close
    Set obj = Nothing
    Application.ScreenUpdating = True
    MsgBox "完成！时间为：" & Format(Timer - ti, "0.000秒")
End Sub

用时2.305秒

vba

0 人点赞