VBA数据字典求助

参考下面的代码，是数据指点的应用：

Sub Macro1()

Dim arr, brr, d, i&, j%, k%, s&

Set d = CreateObject("scripting.dictionary")

arr = Sheets("数据源").Range("a1").CurrentRegion

ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))

For i = 1 To UBound(arr)

    p = ""

    For j = 1 To UBound(arr, 2)

        p = p & "," & arr(i, j)

    Next

    If Not d.exists(p) Then

        s = s + 1

        d(p) = ""

        For k = 1 To UBound(arr, 2)

            brr(s, k) = arr(i, k)

        Next

    End If

Next

Sheets("主表").Range("a1").Resize(s, UBound(brr, 2)) = brr

End Sub

在VBA中使用字典分为前期绑定和后期绑定两种方式，

一、前期绑定：打开VBE编辑器，按下图 *** 作，勾选相应选项就可以直接使用字典了。

二、后期绑定：如下代码即创建了一个名称为d的字典。

Set d = CreateObject("scripting.dictionary")

Sub 字典匹配1() '同一个工作簿里面用字典工具匹配

Application.ScreenUpdating = False '关闭屏幕更新，看不到宏的执行过程，但提高宏运行速度

Application.EnableEvents = False '关闭事件，防止触发事情，提高运行速度

Windows("匹配.xlsm").Activate

'Worksheets("匹配").Select

'Worksheets("数据源").Select

t = Timer

Dim i&, Myr&, arr, j&

Dim d1, d2, d3, d4, d5, d6, d7, k, m&, Arr1

Set d1 = CreateObject("Scripting.Dictionary") '定义字典'

Set d2 = CreateObject("Scripting.Dictionary") '定义字典'

Set d3 = CreateObject("Scripting.Dictionary") '定义字典'

Set d4 = CreateObject("Scripting.Dictionary") '定义字典'

Set d5 = CreateObject("Scripting.Dictionary") '定义字典'

Set d6 = CreateObject("Scripting.Dictionary") '定义字典'

Set d7 = CreateObject("Scripting.Dictionary") '定义字典'

'y = d(Arr(Range("c1:c200"))) + 1

Sheets("数据源").Select '开始运行字典'

With Sheets("数据源")

X = Range("a1").CurrentRegion.Rows.Count '设置最大行'

For i = 2 To X

d1(.Cells(i, 1).Value) = .Cells(i, 5).Value

d2(.Cells(i, 1).Value) = .Cells(i, 8).Value

d3(.Cells(i, 1).Value) = .Cells(i, 9).Value

d4(.Cells(i, 1).Value) = .Cells(i, 10).Value

d5(.Cells(i, 1).Value) = .Cells(i, 11).Value

d6(.Cells(i, 1).Value) = .Cells(i, 12).Value

d7(.Cells(i, 1).Value) = .Cells(i, 13).Value

Next i

End With

Sheets("匹配").Select

With Sheets("匹配")

y = Range("a1").CurrentRegion.Rows.Count '设置最大行'

For Z = 2 To y

.Cells(Z, 28).Value = d1(.Cells(Z, 1).Value)

.Cells(Z, 29).Value = d2(.Cells(Z, 1).Value)

.Cells(Z, 30).Value = d3(.Cells(Z, 1).Value)

.Cells(Z, 31).Value = d4(.Cells(Z, 1).Value)

.Cells(Z, 32).Value = d5(.Cells(Z, 1).Value)

.Cells(Z, 33).Value = d6(.Cells(Z, 1).Value)

.Cells(Z, 34).Value = d7(.Cells(Z, 1).Value)

Next Z

End With

End Sub

Sub 字典匹配2() '不同一个工作簿里面用字典工具匹配

Application.ScreenUpdating = False '关闭屏幕更新，看不到宏的执行过程，但提高宏运行速度

Application.EnableEvents = False '关闭事件，防止触发事情，提高运行速度

'y = d(Arr(Range("c1:c200"))) + 1

Sheets("数据源").Select '开始运行字典'

With Sheets("数据源")

X = Range("a1").CurrentRegion.Rows.Count '设置最大行'

For i = 2 To X

d1(.Cells(i, 1).Value) = .Cells(i, 5).Value

d2(.Cells(i, 1).Value) = .Cells(i, 8).Value

d3(.Cells(i, 1).Value) = .Cells(i, 9).Value

d4(.Cells(i, 1).Value) = .Cells(i, 10).Value

d5(.Cells(i, 1).Value) = .Cells(i, 11).Value

d6(.Cells(i, 1).Value) = .Cells(i, 12).Value

d7(.Cells(i, 1).Value) = .Cells(i, 13).Value

Next i

End With

Windows("匹配.xlsm").Activate '匹配目标

Worksheets("匹配").Select

With Sheets("匹配")

y = Range("a1").CurrentRegion.Rows.Count '设置最大行'

For Z = 2 To y

.Cells(Z, 28).Value = d1(.Cells(Z, 1).Value)

.Cells(Z, 29).Value = d2(.Cells(Z, 1).Value)

.Cells(Z, 30).Value = d3(.Cells(Z, 1).Value)

.Cells(Z, 31).Value = d4(.Cells(Z, 1).Value)

.Cells(Z, 32).Value = d5(.Cells(Z, 1).Value)

.Cells(Z, 33).Value = d6(.Cells(Z, 1).Value)

.Cells(Z, 34).Value = d7(.Cells(Z, 1).Value)

Next Z

End With

End Sub

---