票号段比对的问题，想了好久，求助大家，麻烦了

grf1973

嗯，错误原因找到了。代码中For j = 1 To ux - 1   改成 For j = 1 To ux 就OK了。所差的6条记录都是在一个字轨结束时的。

grf1973

全数组操作，速度有效提升。

1. Sub aa()      '1有2没有
   
2.     With Sheet1
   
3.         r1 = .[b65536].End(3).Row: arr1 = .Range("b2:e" & r1)
   
4.         r2 = .[j65536].End(3).Row: arr2 = .Range("j2:m" & r2)
   
5.     End With
   
6.     Set d = CreateObject("scripting.dictionary")
   
7.     Set d1 = CreateObject("scripting.dictionary")
   
8.     Set d2 = CreateObject("scripting.dictionary")
   
9.     For i = 1 To UBound(arr2)      '把2中字轨对应行号存入字典
   
10.         zg = Trim(arr2(i, 1))   '字轨
    
11.         d(zg) = d(zg) & "," & i
    
12.         If Not d2.exists(zg) Then      '字典d2为数组trr用。数组trr存放各字轨1有2没有的所有数字。
    
13.             k = k + 1
    
14.             d2(zg) = k
    
15.         End If
    
16.     Next
    
17.    
    
18.     For i = 1 To UBound(arr1)      '把1中字轨对应行号存入字典
    
19.         zg = Trim(arr1(i, 1))   '字轨
    
20.         d1(zg) = d1(zg) & "," & i
    
21.     Next
    
22.    
    
23.     Dim crr(0 To 5000000) As Integer
    
24.     dk = d.keys
    
25.     ReDim trr(1 To d.Count, 1 To 5000000) As Long    '数组trr存放各字轨1有2没有的所有数字。
    
26.     For i = 0 To UBound(dk)
    
27.         zg = dk(i)
    
28.         xrr = Split(d(zg), ",")
    
29.         For j = 1 To UBound(xrr)
    
30.             k = Val(xrr(j))
    
31.             s1 = Val(arr2(k, 3)): s2 = Val(arr2(k, 4))       '2中第k行的起始终止号码
    
32.             For p = s1 To s2
    
33.                 crr(p) = 1            '2中存在号码p，数组crr的第p项赋值为1
    
34.             Next
    
35.         Next
    
36.         
    
37.         yrr = Split(d1(zg), ",")
    
38.         xl = d2(zg): trr(xl, 1) = zg   'xl为此字轨在trr中的行数，trr(xl,1)存字轨名
    
39.         For j = 1 To UBound(yrr)
    
40.             k = Val(yrr(j))
    
41.             s1 = Val(arr1(k, 3)): s2 = Val(arr1(k, 4))         '1中第k行的起始终止号码
    
42.             For p = s1 To s2
    
43.                 If crr(p) = 0 Then
    
44.                     trr(xl, 2) = trr(xl, 2) + 1    'trr(xl,2)对应字轨1有2没有的数字个数
    
45.                     trr(xl, trr(xl, 2) + 2) = p 'trr(xl,3)开始存对应字轨1有2没有的所有数字
    
46.                 End If
    
47.             Next
    
48.             
    
49.         Next
    
50.         Erase crr        '清空crr
    
51.     Next
    
52.    
    
53.     k = 0
    
54.     Dim brr(1 To 100000, 1 To 4)
    
55.     For i = 1 To UBound(trr)
    
56.         zg = trr(i, 1)
    
57.         ux = trr(i, 2) + 2     'trr第i行的最大列
    
58.         For j = 3 To ux           '按要求输出
    
59.             k = k + 1
    
60.             brr(k, 1) = zg
    
61.             brr(k, 2) = trr(i, j)
    
62.             If trr(i, ux) - trr(i, j) = ux - j Then  '最后一个数和当前数比，如果递增，直接填充后结束大循环
    
63.                 brr(k, 3) = trr(i, ux)
    
64.                 brr(k, 4) = ux - j + 1
    
65.                 Exit For
    
66.             End If
    
67.             For t = j + 1 To ux        '当前数后面所有数和当前数比，如果不递增，填充后结束小循环，当前数跳到不递增的那个数之前一个
    
68.                 If trr(i, t) - trr(i, j) <> t - j Then
    
69.                     brr(k, 3) = trr(i, t - 1)
    
70.                     brr(k, 4) = t - j
    
71.                     j = t - 1
    
72.                     Exit For
    
73.                 End If
    
74.             Next
    
75.         Next
    
76.     Next
    
77.     With Sheet3
    
78.         .Range("a:d").Clear
    
79.         .[a1].Resize(1, 4) = Array("字轨", "起始号码", "终止号码", "份数")
    
80.         .[a2].Resize(k, 4) = brr
    
81.         .Range("b2:c" & k + 1).NumberFormatLocal = "00000000"
    
82.         .Activate
    
83.     End With
    
84. End Sub
    

复制代码

grf1973

原来代码用字典d2把所有符合条件的数字放在一个字符串中，现在直接把所有符合条件的数字放在一个数组trr中。

无姓人

grf1973 发表于 2014-3-7 11:42
原来代码用字典d2把所有符合条件的数字放在一个字符串中，现在直接把所有符合条件的数字放在一个数组trr中。 ...

非常感谢再一次帮助，程序速度的确提升不少，厉害！我经过了再一次人眼比对，这次结果完全正确了，谢谢，辛苦您了！！

yjh_27

无姓人 发表于 2014-3-6 23:59
非常感谢楼上各位朋友无私的帮助，尤其感谢lanyuu、grf1973、yjh_27这三位老师。我把这三位老师的程序 ...

减集  自定义函数  有错误，已修正。

请测试。

无姓人

yjh_27 发表于 2014-3-7 15:53
减集  自定义函数  有错误，已修正。

请测试。

谢谢，再一次麻烦您了，经测试，这次结果完全正确。非常感谢！！

朱胜利

呼叫GRF1973
请求帮助

efttr55dyf

grf1973 发表于 2014-3-7 11:42
原来代码用字典d2把所有符合条件的数字放在一个字符串中，现在直接把所有符合条件的数字放在一个数组trr中 ...

老师您好！能不能请你给我写个VBA代码？若有空请帮助，若没空 请 谅 打扰。

kszcs

这是高手云集的答案

efttr55dyf

lanyuu 发表于 2014-3-6 12:02
去掉字轨判断，有可能变慢，如果你数据量很大的话，可以先按发票号做一下排序，然后优化一下代码，可以提高 ...

老师您好 请你帮写个VBA代码好吗？若有空请帮助，若没空 请谅打扰，谢谢