VBA中用了七个字典，求改进

f8b1987

菜鸟表示有压力，虽然能用字典法解决两表四列数据核查问题，但是连用7个字典进行判断，不知道如何改进。

1. 
   

复制代码

期待各位高手指点改进，如能把对比出不一致的数据，创建工作表，粘贴差异明细，并在后面备注是表几的最好了。


代码如下：

1. 
   
2. Sub 字典()
   
3. Dim i As Integer, j As Integer, arr(), brr()
   
4. Dim d1 As Object, d2 As Object, d3 As Object
   
5. Dim d4 As Object, d5 As Object, d6 As Object, d7 As Object
   
6. Set d1 = CreateObject("scripting.dictionary")
   
7. Set d2 = CreateObject("scripting.dictionary")
   
8. Set d3 = CreateObject("scripting.dictionary")
   
9. Set d4 = CreateObject("scripting.dictionary")
   
10. Set d5 = CreateObject("scripting.dictionary")
    
11. Set d6 = CreateObject("scripting.dictionary")
    
12. Set d7 = CreateObject("scripting.dictionary")
    
13. arr = Sheet1.Range("a1").CurrentRegion
    
14. brr = Sheet2.Range("a1").CurrentRegion
    
15. For i = 2 To UBound(brr)
    
16. d1(brr(i, 1) & "|" & brr(i, 2) & "|" & brr(i, 3) & "|" & brr(i, 4)) = "正常"
    
17. d2(brr(i, 1) & "|" & brr(i, 2) & "|" & brr(i, 3)) = "金额差异"
    
18. d3(brr(i, 1) & "|" & brr(i, 2) & "|" & brr(i, 4)) = "地区差异"
    
19. d4(brr(i, 1) & "|" & brr(i, 2)) = "地区和金额"
    
20. d5(brr(i, 2) & "|" & brr(i, 3) & "|" & brr(i, 4)) = "日期差异"
    
21. d6(brr(i, 2) & "|" & brr(i, 4)) = "日期和地区"
    
22. d7(brr(i, 2) & "|" & brr(i, 3)) = "日期和金额"
    
23. Next i
    
24. 
    
25. For j = 2 To UBound(arr)
    
26. If d1(arr(j, 1) & "|" & arr(j, 2) & "|" & arr(j, 3) & "|" & arr(j, 4)) = "正常" Then
    
27. arr(j, 5) = d1(arr(j, 1) & "|" & arr(j, 2) & "|" & arr(j, 3) & "|" & arr(j, 4))
    
28. ElseIf d2(arr(j, 1) & "|" & arr(j, 2) & "|" & arr(j, 3)) = "金额差异" Then
    
29. arr(j, 5) = "金额差异"
    
30. ElseIf d3(arr(j, 1) & "|" & arr(j, 2) & "|" & arr(j, 4)) = "地区差异" Then
    
31. arr(j, 5) = "地区差异"
    
32. ElseIf d4(arr(j, 1) & "|" & arr(j, 2)) = "地区和金额" Then
    
33. arr(j, 5) = "地区和金额"
    
34. ElseIf d5(arr(j, 2) & "|" & arr(j, 3) & "|" & arr(j, 4)) = "日期差异" Then
    
35. arr(j, 5) = "日期差异"
    
36. ElseIf d6(arr(j, 2) & "|" & arr(j, 4)) = "日期和地区" Then
    
37. arr(j, 5) = "日期和地区"
    
38. ElseIf d7(arr(j, 2) & "|" & arr(j, 3)) = "日期和金额" Then
    
39. arr(j, 5) = "日期和金额"
    
40. Else
    
41. arr(j, 5) = "待查"
    
42. End If
    
43. Next j
    
44. Sheet1.Range("a1").Resize(UBound(arr), 5) = arr
    
45. Call 字典2
    
46. End Sub
    
47. Sub 字典2()
    
48. Dim i As Integer, j As Integer, arr(), brr()
    
49. Dim d1 As Object, d2 As Object, d3 As Object
    
50. Dim d4 As Object, d5 As Object, d6 As Object, d7 As Object
    
51. Set d1 = CreateObject("scripting.dictionary")
    
52. Set d2 = CreateObject("scripting.dictionary")
    
53. Set d3 = CreateObject("scripting.dictionary")
    
54. Set d4 = CreateObject("scripting.dictionary")
    
55. Set d5 = CreateObject("scripting.dictionary")
    
56. Set d6 = CreateObject("scripting.dictionary")
    
57. Set d7 = CreateObject("scripting.dictionary")
    
58. trow = Sheet1.Range("d65536").End(xlUp).Row
    
59. brr = Sheet1.Range("a1").CurrentRegion
    
60. arr = Sheet2.Range("a1").CurrentRegion
    
61. For i = 2 To UBound(brr)
    
62. d1(brr(i, 1) & "|" & brr(i, 2) & "|" & brr(i, 3) & "|" & brr(i, 4)) = "正常"
    
63. d2(brr(i, 1) & "|" & brr(i, 2) & "|" & brr(i, 3)) = "金额差异"
    
64. d3(brr(i, 1) & "|" & brr(i, 2) & "|" & brr(i, 4)) = "地区差异"
    
65. d4(brr(i, 1) & "|" & brr(i, 2)) = "地区和金额"
    
66. d5(brr(i, 2) & "|" & brr(i, 3) & "|" & brr(i, 4)) = "日期差异"
    
67. d6(brr(i, 2) & "|" & brr(i, 4)) = "日期和地区"
    
68. d7(brr(i, 2) & "|" & brr(i, 3)) = "日期和金额"
    
69. Next i
    
70. 
    
71. For j = 2 To UBound(arr)
    
72. If d1(arr(j, 1) & "|" & arr(j, 2) & "|" & arr(j, 3) & "|" & arr(j, 4)) = "正常" Then
    
73. arr(j, 5) = d1(arr(j, 1) & "|" & arr(j, 2) & "|" & arr(j, 3) & "|" & arr(j, 4))
    
74. ElseIf d2(arr(j, 1) & "|" & arr(j, 2) & "|" & arr(j, 3)) = "金额差异" Then
    
75. arr(j, 5) = "金额差异"
    
76. ElseIf d3(arr(j, 1) & "|" & arr(j, 2) & "|" & arr(j, 4)) = "地区差异" Then
    
77. arr(j, 5) = "地区差异"
    
78. ElseIf d4(arr(j, 1) & "|" & arr(j, 2)) = "地区和金额" Then
    
79. arr(j, 5) = "地区和金额"
    
80. ElseIf d5(arr(j, 2) & "|" & arr(j, 3) & "|" & arr(j, 4)) = "日期差异" Then
    
81. arr(j, 5) = "日期差异"
    
82. ElseIf d6(arr(j, 2) & "|" & arr(j, 4)) = "日期和地区" Then
    
83. arr(j, 5) = "日期和地区"
    
84. ElseIf d7(arr(j, 2) & "|" & arr(j, 3)) = "日期和金额" Then
    
85. arr(j, 5) = "日期和金额"
    
86. Else
    
87. arr(j, 5) = "待查"
    
88. End If
    
89. Next j
    
90. Sheet2.Range("a1").Resize(UBound(arr), 5) = arr
    
91. End Sub
    
92. 
    
93. 
    

复制代码

VBA对比两表四列模表 - 副本.rar (98.86 KB, 下载次数: 273)

2012-6-6 20:21 上传

点击文件名下载附件

麻烦各位了,附件里有程序文件和参考差异的结果。


工作簿中有表一和表二
先在表一对表二核对，然后在表二对表一核对。

先在表一对表二数据查找判断：
如果A/B/C/D列中的数据完全一致，则F列显示正常
如果A/B/C一致，D不同，则F列显示金额差异
如果A/B/D一致，C不同，则F列显示地区差异
如果A/B相同，C/D均不同，则F列为“地区和金额”
如果B/C/D相同，A不同，则F列为“日期差异”
如果B/D相同，A/C不同，则F列为“日期和地区”
如果B/C相同，A/D不同，则F列为“日期和金额”
其他情况，F列返回“待查”

然后继续在表二对表一数据查找判断，判断方式如上

小花鹿

帖代码不如直接说要求好。

f8b1987

小花鹿 发表于 2012-6-6 20:31
帖代码不如直接说要求好。

已补充说明

yaozong

f8b1987 发表于 2012-6-6 21:20
已补充说明

字典2可简化掉。
插在字典1中
'........
Sheet1.Range("a1").Resize(UBound(arr), 5) = arr
   
    '以下代码替代字典2
    d1.RemoveAll
    For i = 2 To UBound(arr)
       d1(arr(i, 2)) = arr(i, 5)
    Next
    For i = 2 To UBound(brr)
       If d1.exists(brr(i, 2)) Then
          brr(i, 5) = d1(brr(i, 2))
       Else
          brr(i, 5) = "待查"
       End If
    Next
    Sheet2.Range("a1").CurrentRegion = brr
    'Call 字典2
End Sub

yaozong

参考附件。。。

f8b1987

yaozong 发表于 2012-6-6 22:40
参考附件。。。

谢谢，代码简洁。另外分享别人的代码
Sub aa()
    Dim d As New Dictionary
    Dim arr1, arr2, arrj
    Dim i As Long, str As String
    Sheets("表一").Range("F2:F" & [F65536].End(xlUp).Row + 1).ClearContents
    arr1 = Sheets("表一").Range("A2:D" & [A65536].End(xlUp).Row)
    arr2 = Sheets("表二").Range("A2:D" & Sheets("表二").[A65536].End(xlUp).Row)
    ReDim arrj(1 To UBound(arr1), 1 To 1)
    For i = 1 To UBound(arr2)
        d(arr2(i, 2)) = Array(arr2(i, 1), arr2(i, 3), arr2(i, 4), i)
    Next i
    For i = 1 To UBound(arr1)
        If d.Exists(arr1(i, 2)) Then
            If arr1(i, 1) = d(arr1(i, 2))(0) And arr1(i, 3) = d(arr1(i, 2))(1) And arr1(i, 4) = d(arr1(i, 2))(2) Then
                arrj(i, 1) = "正常"
            Else
                str = "差异"
                If arr1(i, 1) <> d(arr1(i, 2))(0) Then
                    str = "时间" & str
                End If
                If arr1(i, 3) <> d(arr1(i, 2))(1) Then
                    str = "地区" & str
                End If
                If arr1(i, 4) <> d(arr1(i, 2))(2) Then
                    str = "金额" & str
                End If
                arrj(i, 1) = str
            End If
        Else
            arrj(i, 1) = "待查"
        End If
    Next i
    Sheets("表一").Range("F2").Resize(UBound(arr1), 1) = arrj
End Sub
Sub bb()
    Dim t1 As Double, t2 As Double
    t1 = Timer
    Call aa
    Call cc
    t2 = Timer
    MsgBox t2 - t1
End Sub
Sub cc()
    Dim d As New Dictionary
    Dim arr1, arr2, arrj
    Dim i As Long, str As String
    Sheets("表二").Range("F2:F" & [F65536].End(xlUp).Row + 1).ClearContents
    arr1 = Sheets("表二").Range("A2:D" & [A65536].End(xlUp).Row)
    arr2 = Sheets("表一").Range("A2:D" & Sheets("表一").[A65536].End(xlUp).Row)
    ReDim arrj(1 To UBound(arr1), 1 To 1)
    For i = 1 To UBound(arr2)
        d(arr2(i, 2)) = Array(arr2(i, 1), arr2(i, 3), arr2(i, 4), i)
    Next i
    For i = 1 To UBound(arr1)
        If d.Exists(arr1(i, 2)) Then
            If arr1(i, 1) = d(arr1(i, 2))(0) And arr1(i, 3) = d(arr1(i, 2))(1) And arr1(i, 4) = d(arr1(i, 2))(2) Then
                arrj(i, 1) = "正常"
            Else
                str = "差异"
                If arr1(i, 1) <> d(arr1(i, 2))(0) Then
                    str = "时间" & str
                End If
                If arr1(i, 3) <> d(arr1(i, 2))(1) Then
                    str = "地区" & str
                End If
                If arr1(i, 4) <> d(arr1(i, 2))(2) Then
                    str = "金额" & str
                End If
                arrj(i, 1) = str
            End If
        Else
            arrj(i, 1) = "待查"
        End If
    Next i
    Sheets("表二").Range("F2").Resize(UBound(arr1), 1) = arrj
End Sub

yaozong

f8b1987 发表于 2012-6-7 00:15
谢谢，代码简洁。另外分享别人的代码
Sub aa()
    Dim d As New Dictionary

也可改为这样。
Sub 字典()
Dim d1, arr(), brr(), ar(), br(), k, i, n
    Set d = CreateObject("scripting.dictionary")
    arr = Sheet1.Range("a1").CurrentRegion
    brr = Sheet2.Range("a1").CurrentRegion
    ar = Array("日期", "地区", "金额")
    For i = 2 To UBound(brr)
        d(brr(i, 2)) = Array(brr(i, 1), brr(i, 3), brr(i, 4))
    Next i
    For i = 2 To UBound(arr)
        If d.exists(arr(i, 2)) Then
           br = Array(arr(i, 1), arr(i, 3), arr(i, 4))
           For n = 0 To UBound(br)
              If br(n) <> d(arr(i, 2))(n) Then
                 arr(i, 5) = arr(i, 5) & ar(n)
              End If
           Next
        Else
           arr(i, 5) = "待查"
        End If
        If arr(i, 5) = "" Then
           arr(i, 5) = "OK"
        Else
           If arr(i, 5) = "待查" Then
              arr(i, 5) = arr(i, 5)
           Else
              arr(i, 5) = arr(i, 5) & "异常"
           End If
       End If
    Next
    Sheet1.Range("a1").Resize(UBound(arr), 5) = arr
    d.RemoveAll
    For i = 2 To UBound(arr)
       d(arr(i, 2)) = arr(i, 5)
    Next
    For i = 2 To UBound(brr)
       If d.exists(brr(i, 2)) Then
          brr(i, 5) = d(brr(i, 2))
       Else
          brr(i, 5) = "待查"
       End If
    Next
    Sheet2.Range("a1").CurrentRegion = brr
    Set d = Nothing
End Sub

yaozong

参考附件。。。

f8b1987

yaozong 发表于 2012-6-7 07:05
参考附件。。。

代码简洁了，但运行速度好像还是另外分享那位的代码快些，不过这点速度差异不影响效果，还是谢谢了

yaozong

f8b1987 发表于 2012-6-7 07:52
代码简洁了，但运行速度好像还是另外分享那位的代码快些，不过这点速度差异不影响效果，还是谢谢了

代码少了，不等于优化，多几个字典也无仿，运行顺畅就好。