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

f8b1987

yaozong 发表于 2012-6-7 08:11
代码少了，不等于优化，多几个字典也无仿，运行顺畅就好。

嗯。我主要也是学习简化，毕竟7个字典看上去太繁琐了

guojianlin1985

下载看看。

liuguansky

B列即单号惟 一，一个字典就OK了啊。
如果d(单号)存在即对工作表所对应记录进行比对A,C,D列。[1/2/4]相加匹配到1-7七种可能。
返回七种可能。
1
2
1 2
4
1 4
2 4
1 2 4
0或D（单号）不存在返回异常。

daveman

Sub test()
    arr = Sheet2.Range("a1").CurrentRegion
    Set dic = CreateObject("scripting.dictionary")
    For i = 2 To UBound(arr)
        dic(arr(i, 2)) = i
    Next
    arr1 = Sheet1.Range("a1").CurrentRegion
    For i = 2 To UBound(arr1)
        For j = 1 To UBound(arr1, 2) - 1
            If dic.exists(arr1(i, 2)) Then
                If arr1(i, j) <> arr(dic(arr1(i, 2)), j) Then
                    s = s & j
                End If
            End If
        Next
                Select Case s
                    Case ""
                        arr1(i, UBound(arr1, 2)) = "正常"
                    Case "4"
                        arr1(i, UBound(arr1, 2)) = "金额差异"
                    Case "3"
                        arr1(i, UBound(arr1, 2)) = "地区差异"
                    Case "34"
                        arr1(i, UBound(arr1, 2)) = "地区和金额"
                    Case "1"
                        arr1(i, UBound(arr1, 2)) = "日期差异"
                    Case "13"
                        arr1(i, UBound(arr1, 2)) = "日期和地区"
                    Case "14"
                        arr1(i, UBound(arr1, 2)) = "日期和金额"
                    Case Else
                        arr1(i, UBound(arr1, 2)) = "待查"
                End Select
                s = ""
    Next
    Sheet1.Range("a1").CurrentRegion = arr1
    arr = Sheet1.Range("a1").CurrentRegion
    Set dic = CreateObject("scripting.dictionary")
    For i = 2 To UBound(arr)
        dic(arr(i, 2)) = i
    Next
    arr1 = Sheet2.Range("a1").CurrentRegion
    For i = 2 To UBound(arr1)
        For j = 1 To UBound(arr1, 2) - 1
            If dic.exists(arr1(i, 2)) Then
                If arr1(i, j) <> arr(dic(arr1(i, 2)), j) Then
                    s = s & j
                End If
            End If
        Next
                Select Case s
                    Case ""
                        arr1(i, UBound(arr1, 2)) = "正常"
                    Case "4"
                        arr1(i, UBound(arr1, 2)) = "金额差异"
                    Case "3"
                        arr1(i, UBound(arr1, 2)) = "地区差异"
                    Case "34"
                        arr1(i, UBound(arr1, 2)) = "地区和金额"
                    Case "1"
                        arr1(i, UBound(arr1, 2)) = "日期差异"
                    Case "13"
                        arr1(i, UBound(arr1, 2)) = "日期和地区"
                    Case "14"
                        arr1(i, UBound(arr1, 2)) = "日期和金额"
                    Case Else
                        arr1(i, UBound(arr1, 2)) = "待查"
                End Select
                s = ""
    Next
    Sheet2.Range("a1").CurrentRegion = arr1
End Sub

香川群子

关注一下七个字典的问题。

2007小金猪

收藏研究，学习备用

临时户口

我写了表2在表一中进行比对判断，你按照我的代码思路可以自己写一个表1在表2中进行比对。

1. Sub chaxun()
   
2.     Dim d1     As New Dictionary
   
3.     Dim d2     As New Dictionary
   
4.     Dim arr
   
5.     Dim brr
   
6.     Dim x, m
   
7.     Dim 结果1, 结果2, 结果3
   
8.     arr = Sheets(1).Range("a2:d" & Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row) '表1数据装入arr数组
   
9.     brr = Sheets(2).Range("a2:d" & Sheets(2).Cells(Rows.Count, 1).End(xlUp).Row) '表2数据装入brr数据
   
10.     For x = 1 To UBound(arr)
    
11.         m = m + 1
    
12.         d1(arr(x, 2)) = m   '订单号唯一的，订单号作为key 他所在数组的行数作为item装入字典d1中
    
13.     Next
    
14.     m = 0
    
15.     For x = 1 To UBound(brr)
    
16.         m = m + 1
    
17.         d2(arr(x, 2)) = m '订单号唯一的，订单号作为key 他所在数组的行数作为item装入字典d2中
    
18.     Next
    
19.     '表2中每行数据在表一中的数据的行数找出来，然后一一进行判断，根据判断结果输出结果
    
20.     For x = 1 To UBound(brr)
    
21.         m = d1(brr(x, 2))
    
22.         If m = 0 Then
    
23.             Cells(x + 1, "f") = "待查"
    
24.         Else
    
25.             If arr(m, 1) <> brr(x, 1) Then 结果1 = "日期"
    
26.             If arr(m, 3) <> brr(x, 3) Then 结果2 = "地区"
    
27.             If arr(m, 4) <> brr(x, 4) Then 结果3 = "金额"
    
28.             If 结果1 = "" And 结果2 = "" And 结果3 = "" Then
    
29.                 Cells(x + 1, "f").Value = "正常"
    
30.             ElseIf 结果1 <> "" And 结果2 <> "" And 结果3 <> "" Then
    
31.                 Cells(x + 1, "f").Value = "待查"
    
32.             Else
    
33.                 Cells(x + 1, "f").Value = 结果1 & 结果2 & 结果3 & "差异"
    
34.             End If
    
35.         End If
    
36.         结果1 = ""
    
37.         结果2 = ""
    
38.         结果3 = ""
    
39.     Next
    
40. End Sub
    

复制代码

临时户口

我的附件附上

︶〃续写·v枫

谢谢分享，学习学习

李桥贵

︶〃续写·v枫 发表于 2020-12-10 11:01
谢谢分享，学习学习

各位大理大师辛苦了，这个对于做人事或财务工作的同志非常有用。在此谢谢各位大师。
请大师再辛苦一下，标出并统计出有差异项目的类型、个数和所在表格的位置，查找起
来方便多。