[已解决]怎么用字典匹配数额精确到小数第二位

glhfgtd

前不久从社区老师的精妙解答中学到了VBA字典功能的强大一面，可在实际使用中发现一个问题，就是当把小数导入字典后，字典得到的匹配结果含有很多近似值之间的匹配，求教社区的高手老师们帮忙修改下我的代码，使其能够进行精确匹配(数额不等的不要匹配). 谢谢
Dict Matching Q _Exact Matching.zip (20.77 KB, 下载次数: 13)

2014-12-16 07:51 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

fffox

2014-12-16 08:43

1. Sub MatchAnB()
   
2.     Dim d1, arr, brr, mrr, RN&, n&, aRN&, Amt#, ttt
   
3.     ttt = Timer
   
4.     With Application
   
5.         .ScreenUpdating = False
   
6.         .EnableEvents = False
   
7.         .DisplayAlerts = False
   
8.         .Calculation = xlCalculationManual
   
9.     End With
   
10.    
    
11.     Set d1 = CreateObject("scripting.dictionary")
    
12.     arr = Sheet1.Range("A1:D" & Sheet1.Cells(Rows.Count, 1).End(3).Row)
    
13.     brr = Sheet2.Range("A1:D" & Sheet2.Cells(Rows.Count, 1).End(3).Row)
    
14.     For RN = 3 To UBound(arr)
    
15.         Amt = arr(RN, 3)
    
16.         d1(Amt) = d1(Amt) & "," & RN
    
17.     Next
    
18.     For RN = 3 To UBound(brr)
    
19.         Amt = brr(RN, 3)
    
20.         If d1.exists(Amt) Then
    
21.             mrr = Split(d1(Amt), ",")
    
22.             If UBound(mrr) >= 1 Then
    
23.             
    
24.                 If brr(RN, 2) <> "" Then
    
25.                     For n = 1 To UBound(mrr)
    
26.                         aRN = Val(mrr(n))
    
27.                         If aRN > 0 Then
    
28.                             If brr(RN, 2) = arr(aRN, 2) Then
    
29.                                 brr(RN, 4) = arr(aRN, 1)
    
30.                                 arr(aRN, 4) = brr(RN, 1)
    
31.                                 d1(Amt) = Replace(d1(Amt) & ",", "," & aRN & ",", ",")
    
32.                                 GoTo aa
    
33.                             End If
    
34.                         End If
    
35.                     Next
    
36.                 End If
    
37.                
    
38.             End If
    
39.         End If
    
40. aa:
    
41.     Next
    
42.     Sheet1.[d1].Resize(UBound(arr), 1) = Application.Index(arr, , 4)
    
43.     Sheet2.[d1].Resize(UBound(brr), 1) = Application.Index(brr, , 4)
    
44.    
    
45.     With Sheet1.Range("A2:D" & Sheet1.Cells(Rows.Count, 1).End(xlUp).Row)
    
46.         .AutoFilter Field:=4, Criteria1:="<>"
    
47.         .Offset(1, 0).SpecialCells(xlCellTypeVisible).Copy Sheet3.Range("A" & Rows.Count).End(xlUp).Offset(1)
    
48.         .AutoFilter
    
49.     End With
    
50.     With Sheet2.Range("A2:D" & Sheet2.Cells(Rows.Count, 1).End(xlUp).Row)
    
51.         .AutoFilter Field:=4, Criteria1:="<>"
    
52.         .Offset(1, 0).SpecialCells(xlCellTypeVisible).Copy Sheet3.Range("F" & Rows.Count).End(xlUp).Offset(1)
    
53.         .AutoFilter
    
54.     End With
    
55.     With Sheet3
    
56.         .Range("A3:D" & .Cells(Rows.Count, "A").End(xlUp).Row).Sort Key1:=.Range("A3"), Order1:=xlAscending, Header:=xlNo
    
57.         .Range("F3:I" & .Cells(Rows.Count, "I").End(xlUp).Row).Sort Key1:=.Range("I3"), Order1:=xlAscending, Header:=xlNo
    
58.         .Range("K3").Resize(.Cells(Rows.Count, 1).End(xlUp).Row - 2, 1).Formula = "=H3-C3"
    
59.     End With
    
60.    
    
61.     With Application
    
62.         .ScreenUpdating = True
    
63.         .EnableEvents = True
    
64.         .DisplayAlerts = True
    
65.         .Calculation = xlCalculationAutomatic
    
66.     End With
    
67.     MsgBox Timer - ttt & " sec spent"
    
68. End Sub
    

复制代码

跳转到最佳答案楼层

qh8600

给字典赋值的Amt变量类型是long，所以把后面的小数都忽略了，改成 Amt As Double 双精度试试

fffox

代码中，你的Amt的类型是&，但在实际使用中，Amt = arr(RN, 3)。而arr(RN, 3)是金额，有小数的，Amt取值时自动转换成整数了，所以出现有误差。
定义时Amt为单精度或双精度就可以了

fffox

1. Sub MatchAnB()
   
2.     Dim d1, arr, brr, mrr, RN&, n&, aRN&, Amt#, ttt
   
3.     ttt = Timer
   
4.     With Application
   
5.         .ScreenUpdating = False
   
6.         .EnableEvents = False
   
7.         .DisplayAlerts = False
   
8.         .Calculation = xlCalculationManual
   
9.     End With
   
10.    
    
11.     Set d1 = CreateObject("scripting.dictionary")
    
12.     arr = Sheet1.Range("A1:D" & Sheet1.Cells(Rows.Count, 1).End(3).Row)
    
13.     brr = Sheet2.Range("A1:D" & Sheet2.Cells(Rows.Count, 1).End(3).Row)
    
14.     For RN = 3 To UBound(arr)
    
15.         Amt = arr(RN, 3)
    
16.         d1(Amt) = d1(Amt) & "," & RN
    
17.     Next
    
18.     For RN = 3 To UBound(brr)
    
19.         Amt = brr(RN, 3)
    
20.         If d1.exists(Amt) Then
    
21.             mrr = Split(d1(Amt), ",")
    
22.             If UBound(mrr) >= 1 Then
    
23.             
    
24.                 If brr(RN, 2) <> "" Then
    
25.                     For n = 1 To UBound(mrr)
    
26.                         aRN = Val(mrr(n))
    
27.                         If aRN > 0 Then
    
28.                             If brr(RN, 2) = arr(aRN, 2) Then
    
29.                                 brr(RN, 4) = arr(aRN, 1)
    
30.                                 arr(aRN, 4) = brr(RN, 1)
    
31.                                 d1(Amt) = Replace(d1(Amt) & ",", "," & aRN & ",", ",")
    
32.                                 GoTo aa
    
33.                             End If
    
34.                         End If
    
35.                     Next
    
36.                 End If
    
37.                
    
38.             End If
    
39.         End If
    
40. aa:
    
41.     Next
    
42.     Sheet1.[d1].Resize(UBound(arr), 1) = Application.Index(arr, , 4)
    
43.     Sheet2.[d1].Resize(UBound(brr), 1) = Application.Index(brr, , 4)
    
44.    
    
45.     With Sheet1.Range("A2:D" & Sheet1.Cells(Rows.Count, 1).End(xlUp).Row)
    
46.         .AutoFilter Field:=4, Criteria1:="<>"
    
47.         .Offset(1, 0).SpecialCells(xlCellTypeVisible).Copy Sheet3.Range("A" & Rows.Count).End(xlUp).Offset(1)
    
48.         .AutoFilter
    
49.     End With
    
50.     With Sheet2.Range("A2:D" & Sheet2.Cells(Rows.Count, 1).End(xlUp).Row)
    
51.         .AutoFilter Field:=4, Criteria1:="<>"
    
52.         .Offset(1, 0).SpecialCells(xlCellTypeVisible).Copy Sheet3.Range("F" & Rows.Count).End(xlUp).Offset(1)
    
53.         .AutoFilter
    
54.     End With
    
55.     With Sheet3
    
56.         .Range("A3:D" & .Cells(Rows.Count, "A").End(xlUp).Row).Sort Key1:=.Range("A3"), Order1:=xlAscending, Header:=xlNo
    
57.         .Range("F3:I" & .Cells(Rows.Count, "I").End(xlUp).Row).Sort Key1:=.Range("I3"), Order1:=xlAscending, Header:=xlNo
    
58.         .Range("K3").Resize(.Cells(Rows.Count, 1).End(xlUp).Row - 2, 1).Formula = "=H3-C3"
    
59.     End With
    
60.    
    
61.     With Application
    
62.         .ScreenUpdating = True
    
63.         .EnableEvents = True
    
64.         .DisplayAlerts = True
    
65.         .Calculation = xlCalculationAutomatic
    
66.     End With
    
67.     MsgBox Timer - ttt & " sec spent"
    
68. End Sub
    

复制代码

glhfgtd

原来如此，怪不得我自己改了半天，都没法精确到小数 可现在qh8600和fffox两位高手都给予了正确的解答，我不知该给谁设正确答案了，fffox写的更具体，就投他吧。同时万分感谢qh8600的精确解答