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

无姓人

票号段比对-2003版本-论坛求助-正式.rar (118.05 KB, 下载次数: 15)

2014-3-4 22:42 上传

点击文件名下载附件
票号段比对

票号段比对的问题，想了好久没想出来，求助大家，麻烦了，详见附件

sheet1表中 A2:F169中的D2:E169在I2:N3829中的L2:M3829中比对，如果字轨相同，则把A2:F169中 有 而I2:N3829中 没有 的票号段写入sheet3     

举例：     
D3:E3 为以下内容     
00094001----00124000
     
L3:M6为以下内容     
00094001---- 00095953
00095955---- 00109501
00109503---- 00113745
00113747---- 00118858   
  
sheet3的结果则为     
起始号码    终止号码     份数   
00095954  00095954     1   
00109502  00109502     1   
00113746  00113746     1   
     
sheet1表中 A2:F169中的D2:E169在I2:N3829中的L2:M3829中比对，如果字轨相同，则把A2:F169中 没有 而I2:N3829 有 的票号段写入sheet4     

举例：     
D169:E169 为以下内容     
04373901---- 04373914
     
L2400:M2400为以下内容     
04373901---- 04373993
     
sheet4的结果则为     
     
起始号码      终止号码      份数   
04373915    04373993    79   

excelvlookup

坐等，我也想要

lxzxmpx

搞得一团粥一样,可能只有你自己才能看得明白,
04373915    04373993    79   
这几个数据根本都找不到!
看是不是这样的
1.rar (136.95 KB, 下载次数: 6)

2014-3-5 00:01 上传

点击文件名下载附件

黄金万两︶ㄣ

如果我的答案对你有帮助，请赏我一朵鲜花。Sub 一没有()
Set d = CreateObject("Scripting.Dictionary")
Dim i, j, n, l, a, arr, arr1, brr1
Dim brr()
arr1 = Sheet1.Range("c2:e" & Cells(Rows.Count, 1).End(3).Row).Value
arr = Sheet1.Range("k2:m" & Cells(Rows.Count, "i").End(3).Row).Value
  For i = 1 To UBound(arr1)
    For j = 1 To UBound(arr)
      If arr1(i, 2) = arr(j, 2) Then
        n = n + 1
      End If
    Next j
      If n = 0 Then
        l = l + 1
          ReDim Preserve brr(1 To 1, 1 To l)
            brr(1, l) = arr1(i, 2)
      End If
    n = 0
  Next i
brr1 = WorksheetFunction.Transpose(brr)
  For i = 1 To UBound(brr1)
    a = brr1(i, 1)
      d(a) = d(a) + 1
  Next i
Sheet4.Range("a1:c1") = Array("起始号码", "终止号码", "份数")
Sheet4.Range("a2").Resize(d.Count) = WorksheetFunction.Transpose(d.Keys)
Sheet4.Range("b2").Resize(d.Count) = WorksheetFunction.Transpose(d.Keys)
Sheet4.Range("c2").Resize(d.Count) = WorksheetFunction.Transpose(d.Items)
d.RemoveAll
Set d = Nothing
End Sub

Sub 二没有()
Set d = CreateObject("Scripting.Dictionary")
Dim i, j, n, l, a, arr, arr1, brr1
Dim brr()
arr = Sheet1.Range("c2:e" & Cells(Rows.Count, 1).End(3).Row).Value
arr1 = Sheet1.Range("k2:m" & Cells(Rows.Count, "i").End(3).Row).Value
  For i = 1 To UBound(arr1)
    For j = 1 To UBound(arr)
      If arr1(i, 2) = arr(j, 2) Then
        n = n + 1
      End If
    Next j
      If n = 0 Then
        l = l + 1
          ReDim Preserve brr(1 To 1, 1 To l)
            brr(1, l) = arr1(i, 2)
      End If
    n = 0
  Next i
brr1 = WorksheetFunction.Transpose(brr)
  For i = 1 To UBound(brr1)
    a = brr1(i, 1)
      d(a) = d(a) + 1
  Next i
Sheet3.Range("a1:c1") = Array("起始号码", "终止号码", "份数")
Sheet3.Range("a2").Resize(d.Count) = WorksheetFunction.Transpose(d.Keys)
Sheet3.Range("b2").Resize(d.Count) = WorksheetFunction.Transpose(d.Keys)
Sheet3.Range("c2").Resize(d.Count) = WorksheetFunction.Transpose(d.Items)
d.RemoveAll
Set d = Nothing
End Sub

黄金万两︶ㄣ

如果我的答案对你有帮助，请赏我一朵鲜花。
上附件了，如果不是你的要求，请更好的模拟效果！

lanyuu

1. Sub test()
   
2. Dim arr1, arr2, h%, arr, b As Boolean
   
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, 3) And arr2(j, 3) <= arr1(i, 4) Then
    
14.                     If arr2(j, 2) > arr1(i, 4) - arr2(j, 3) + 1 Then
    
15.                         p = arr1(i, 4) - arr2(j, 3) + 1
    
16.                     Else
    
17.                         p = arr2(j, 2)
    
18.                     End If
    
19.                     For k = 1 To p
    
20.                         arr(arr2(j, 3) - arr1(i, 3) + k) = 1
    
21.                     Next k
    
22.                 End If
    
23.             End If
    
24.         
    
25.         Next j
    
26.         b = False
    
27.         For l = 1 To UBound(arr)
    
28.             If arr(l) = 1 Then
    
29.                 If b Then
    
30.                     .Cells(h, 2) = Format(arr1(i, 3) + l - 2, "00000000")
    
31.                     .Cells(h, 3) = .Cells(h, 2) - .Cells(h, 1) + 1
    
32.                     h = h + 1
    
33.                 End If
    
34.                 b = False
    
35.                
    
36.             Else
    
37.                
    
38.                 If Not b Then
    
39.                     .Cells(h, 1) = Format(arr1(i, 3) + l - 1, "00000000")
    
40.                 End If
    
41.                 b = True
    
42.             End If
    
43.         Next l
    
44.         If b Then
    
45.                 .Cells(h, 2) = Format(arr1(i, 3) + l - 2, "00000000")
    
46.                 .Cells(h, 3) = .Cells(h, 2) - .Cells(h, 1) + 1
    
47.                 h = h + 1
    
48.         End If
    
49.             
    
50.     Next i
    
51. End With
    
52. End Sub
    

复制代码

调试了好几次，比较绕人。

无姓人

lxzxmpx 发表于 2014-3-4 23:58
搞得一团粥一样,可能只有你自己才能看得明白,
04373915    04373993    79   
这几个数据根本都找不到! ...

这几个数据正是我要得到的结果，简单的说就是得到票号的断号

无姓人

谢谢楼上两位热心人，那么晚了还在帮我，谢谢！辛苦了！不过不是我想要的结果，可能是我没表达清楚。简单的说就是找出断号。
D2:E2  00010001---00040000是一个票号段，份数为30000份，先用 D2:E2在L2:M3829中比对，由于L2:M2的票号段也是 00010001---00040000，并且字轨都是201201，所以不用管了。
D3:E3  00094001---00124000,再用 D3:E3在L2:M3829中比对，由于L3:M3的票号段00094001---00095953，字轨都是201201，所以断号为00095954---00124000写入表sheet3,
由于L4:M4  为 00095955---00109501,所以已经写入sheet3的值应该更改为
00095954---00095954
00109502---00124000
如此循环判断，不知道现在说清楚没有？模拟结果在附件的sheet3和sheet4中，麻烦了

无姓人

lanyuu 发表于 2014-3-5 08:47
调试了好几次，比较绕人。

牛人，太感谢了，正是我要的结果!

无姓人

lanyuu 发表于 2014-3-5 08:47
调试了好几次，比较绕人。

不好意思，我先看了sheet3表中的前几条结果是对的，可能太高兴了！后来仔细查看所有程序得到的结果发现，有部分结果是错的。详见附件中的sheet3,sheet4表中的错误说明。麻烦您帮我再改改，万分感谢！ 票号段比对-论坛求助-lanyuu .rar (201.12 KB, 下载次数: 8)

2014-3-5 12:37 上传

点击文件名下载附件