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

lanyuu

1. Sub test()
   
2. Dim arr1, arr2, h%, arr, b As Boolean, s%, e%
   
3. arr1 = Sheets("sheet1").Range("b2").Resize(Sheets("sheet1").Range("b65536").End(xlUp).Row - 1, 4)
   
4. arr2 = Sheets("sheet1").Range("j2").Resize(Sheets("sheet1").Range("j65536").End(xlUp).Row - 1, 4)
   
5. h = 2
   
6. With Sheets("sheet3")
   
7. 
   
8.     .Range("a2:c65536").ClearContents
   
9.     For i = 1 To UBound(arr1)
   
10.         ReDim arr(1 To arr1(i, 2))
    
11.         For j = 1 To UBound(arr2)
    
12.             If arr2(j, 1) = arr1(i, 1) Then
    
13.                 If arr2(j, 3) <= arr1(i, 4) And arr2(j, 4) >= arr1(i, 3) Then
    
14.                     If arr2(j, 3) > arr1(i, 3) Then
    
15.                         
    
16.                         s = arr2(j, 3) - arr1(i, 3)
    
17.                     Else
    
18.                         s = 0
    
19.                     End If
    
20.                     If arr2(j, 4) < arr1(i, 4) Then
    
21.                         e = arr2(j, 4) - arr1(i, 4)
    
22.                     Else
    
23.                         e = 0
    
24.                     End If
    
25.                     For k = 1 + s To UBound(arr) + e
    
26.                         arr(k) = 1
    
27.                     Next k
    
28.                 End If
    
29.             End If
    
30.         
    
31.         Next j
    
32.         b = False
    
33.         For l = 1 To UBound(arr)
    
34.             If arr(l) = 1 Then
    
35.                 If b Then
    
36.                     .Cells(h, 2) = Format(arr1(i, 3) + l - 2, "00000000")
    
37.                     .Cells(h, 3) = .Cells(h, 2) - .Cells(h, 1) + 1
    
38.                     h = h + 1
    
39.                 End If
    
40.                 b = False
    
41.                
    
42.             Else
    
43.                
    
44.                 If Not b Then
    
45.                     .Cells(h, 1) = Format(arr1(i, 3) + l - 1, "00000000")
    
46.                 End If
    
47.                 b = True
    
48.             End If
    
49.         Next l
    
50.         If b Then
    
51.                 .Cells(h, 2) = Format(arr1(i, 3) + l - 2, "00000000")
    
52.                 .Cells(h, 3) = .Cells(h, 2) - .Cells(h, 1) + 1
    
53.                 h = h + 1
    
54.         End If
    
55.             
    
56.     Next i
    
57. End With
    
58. End Sub
    

复制代码

lanyuu

无姓人 发表于 2014-3-5 12:38
不好意思，我先看了sheet3表中的前几条结果是对的，可能太高兴了！后来仔细查看所有程序得到的结果发现， ...

向你致敬，你非常仔细，我没注意sheet4，所以考虑的情况不全，现在再看看。

grf1973

1. Sub tt()      '1有2没有
   
2.     arr1 = Sheets("sheet1").Range("b2").Resize(Sheets("sheet1").Range("b65536").End(xlUp).Row - 1, 4)
   
3.     arr2 = Sheets("sheet1").Range("j2").Resize(Sheets("sheet1").Range("j65536").End(xlUp).Row - 1, 4)
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     Set d1 = CreateObject("scripting.dictionary")
   
6.     For i = 1 To UBound(arr2)      '把2中字轨+号码存入字典
   
7.         zg = arr2(i, 1)   '字轨
   
8.         For j = Val(arr2(i, 3)) To Val(arr2(i, 4))
   
9.             xkey = zg & "," & j
   
10.             d(xkey) = ""
    
11.         Next
    
12.     Next
    
13.    
    
14.     For i = 1 To UBound(arr1)      '检查1中字轨+号码是否在字典中，如不在，则筛选出来
    
15.         zg = arr1(i, 1)
    
16.         For j = Val(arr1(i, 3)) To Val(arr1(i, 4))
    
17.             xkey = zg & "," & j
    
18.             If Not d.exists(xkey) Then d1(zg) = d1(zg) & "," & j  '把不在字典d中的号码存入字典d1
    
19.         Next
    
20.     Next
    
21.    
    
22.     d1k = d1.keys: d1t = d1.items
    
23.     Dim brr(1 To 100000, 1 To 4)
    
24.     For i = 0 To UBound(d1k)
    
25.         zg = d1k(i)
    
26.         xrr = Split(d1t(i), ",")
    
27.         For j = 1 To UBound(xrr) - 1
    
28.             k = k + 1
    
29.             brr(k, 1) = zg
    
30.             brr(k, 2) = Format(xrr(j), "00000000")
    
31.             For t = j + 1 To UBound(xrr)
    
32.                 If xrr(t) - xrr(j) <> 1 Then
    
33.                     brr(k, 3) = Format(xrr(t - 1), "00000000")
    
34.                     brr(k, 4) = xrr(t - 1) - xrr(j) + 1
    
35.                     j = t - 1
    
36.                     Exit For
    
37.                 End If
    
38.             Next
    
39.         Next
    
40.     Next
    
41.    
    
42.     Sheet3.[g2].Resize(k, 4) = brr
    
43.    
    
44. End Sub

复制代码

我的电脑运行1分钟左右

grf1973

第32句得改成 If xrr(t) - xrr(j) <> t-j Then

无姓人

grf1973 发表于 2014-3-5 14:37
第32句得改成 If xrr(t) - xrr(j)  t-j Then

非常感谢，大部分结果正确，但有些小问题。麻烦再看下，另外帮我把sheet4表的数据也写一下，我改了您的代码结果不正确,谢谢！

1、因为sheet1中的L312:M312为00837828---00837900，L313:M313为00837903---00838000
所以sheet3表中的结果应该为00837901--00837902，而sheet3表中的H284   实际为00837901,少了00837902这张票。


2、sheet3表中的H332:H360 实际为01114371--01114399,应该为01114371--01114400，少01114400这张票。



3、sheet3表中的H399:H417 实际为02466431--02466449,应该为02466431--02466450,少02466450这张票


1-3问题类同。

4 sheet3表中的H306:I306 00277001---00278800,而sheet1表中的L21:M21的票号段为00276682---00278799,票号段
00277001---00278800部分包含在00276682---00278799中，所以结果错误.
由于下一行L22:M22的票号段为00278801---00288478，所以正确结果应该仅仅为00278800这一张票。
票号段比对-论坛求助-grf1973.rar (165.73 KB, 下载次数: 2)

2014-3-5 16:42 上传

点击文件名下载附件

无姓人

lanyuu 发表于 2014-3-5 13:59
向你致敬，你非常仔细，我没注意sheet4，所以考虑的情况不全，现在再看看。

感谢您不厌其烦的帮我，没想到您这么快就写好了，对不起，我现在才看见，抱歉！我刚才仔细看了一下，结果基本正确，但还有一点小问题，麻烦再帮忙看看，麻烦了！！
请看附件中sheet3中的20行及sheet4中的第2行

票号段比对-第2次求助lanyuu.rar (178.97 KB, 下载次数: 1)

2014-3-5 22:25 上传

点击文件名下载附件

yjh_27

无姓人 发表于 2014-3-5 22:25
感谢您不厌其烦的帮我，没想到您这么快就写好了，对不起，我现在才看见，抱歉！我刚才仔细看了一下，结果 ...

不知有无 某字轨 无对应数据 情况需判断？

附件晚上发

无姓人

yjh_27 发表于 2014-3-6 10:49
不知有无 某字轨 无对应数据 情况需判断？

附件晚上发

没有，所有字轨都有对应数据，谢谢！期待！！

lanyuu

无姓人 发表于 2014-3-5 22:25
感谢您不厌其烦的帮我，没想到您这么快就写好了，对不起，我现在才看见，抱歉！我刚才仔细看了一下，结果 ...

我不得不佩服你的仔细。你看一下那两个的字轨是不一样的，我在里面加入了字轨判断，如果不需要字轨判断我就改一下代码，如果是字轨输入错误你就改一下字轨。如果不判断字轨，速度应该能再快一点

lanyuu

1. Sub test()
   
2. Dim arr1, arr2, h%, arr, b As Boolean, s%, e%
   
3. arr1 = Sheets("sheet1").Range("b2").Resize(Sheets("sheet1").Range("b65536").End(xlUp).Row - 1, 4)
   
4. arr2 = Sheets("sheet1").Range("j2").Resize(Sheets("sheet1").Range("j65536").End(xlUp).Row - 1, 4)
   
5. h = 2
   
6. With Sheets("sheet3")
   
7. 
   
8.     .Range("a2:c65536").ClearContents
   
9.     For i = 1 To UBound(arr1)
   
10.         ReDim arr(1 To arr1(i, 2))
    
11.         For j = 1 To UBound(arr2)
    
12.             'If arr2(j, 1) = arr1(i, 1) Then
    
13.                 If arr2(j, 3) <= arr1(i, 4) And arr2(j, 4) >= arr1(i, 3) Then
    
14.                     If arr2(j, 3) > arr1(i, 3) Then
    
15.                         
    
16.                         s = arr2(j, 3) - arr1(i, 3)
    
17.                     Else
    
18.                         s = 0
    
19.                     End If
    
20.                     If arr2(j, 4) < arr1(i, 4) Then
    
21.                         e = arr2(j, 4) - arr1(i, 4)
    
22.                     Else
    
23.                         e = 0
    
24.                     End If
    
25.                     For k = 1 + s To UBound(arr) + e
    
26.                         arr(k) = 1
    
27.                     Next k
    
28.                 End If
    
29.             'End If
    
30.         
    
31.         Next j
    
32.         b = False
    
33.         For l = 1 To UBound(arr)
    
34.             If arr(l) = 1 Then
    
35.                 If b Then
    
36.                     .Cells(h, 2) = Format(arr1(i, 3) + l - 2, "00000000")
    
37.                     .Cells(h, 3) = .Cells(h, 2) - .Cells(h, 1) + 1
    
38.                     h = h + 1
    
39.                 End If
    
40.                 b = False
    
41.                
    
42.             Else
    
43.                
    
44.                 If Not b Then
    
45.                     .Cells(h, 1) = Format(arr1(i, 3) + l - 1, "00000000")
    
46.                 End If
    
47.                 b = True
    
48.             End If
    
49.         Next l
    
50.         If b Then
    
51.                 .Cells(h, 2) = Format(arr1(i, 3) + l - 2, "00000000")
    
52.                 .Cells(h, 3) = .Cells(h, 2) - .Cells(h, 1) + 1
    
53.                 h = h + 1
    
54.         End If
    
55.             
    
56.     Next i
    
57. End With
    
58. End Sub
    

复制代码

去掉字轨判断，有可能变慢，如果你数据量很大的话，可以先按发票号做一下排序，然后优化一下代码，可以提高一点速度