[已解决]求助：数据比对，无法用函数解决，希望论坛朋友帮我用VBA解决，感激不尽！！！

斜阳几度

感激论坛高手的无私帮助！！斜阳几度再次深深谢过！！！
  说明：
    所有数据都是1或者2。A列数据10万个，B列数据16个。
    判断B1:B16单元格(16个单元格)是否与A1:A16单元格（16个单元格）值完全相等，如不等，则判断B1:B16是否与A2:A17单元格数据完全相等，依次判断（相当于函数里面的下拉），如B1:B16单元格与A1:A16单元格相等，则将A17单元格返回到E1中（第二条信息返回E2…依次排列），同时将A17的行数值返回到D1（第二条信息返回到D2…依次排列）。这样一条信息采集完成，逐行比对，依次采集所有信息。
    完成后，再判断B2:B16单元格(15个单元格)是否与A1:A15单元格（15个单元格）值完全相等，如不等，则判断B2:B16是否与A2:A16单元格数据完全相等，依次判断，如B2:B16单元格与A1:A15单元格相等，则将A16单元格返回到E列中，同时将A16的行数值返回到D列。如有与已采集数据行数重复，则不再采集，这样依次采集所有信息。
    完成后，再判断B3:B16单元格(14个单元格)是否与A1:A14单元格（14个单元格）值完全相等，如不等，则判断B3:B16是否与A2:A15单元格数据完全相等，依次判断，如B3:B16单元格与A1:A14单元格相等，则将A15单元格返回到E列中，同时将A15的行数值返回到D列。如有与已采集数据行数重复，则不再采集，这样依次采集所有信息。
    以上三次循环，采集后退出程序！

本表版本为 excel 2013 由于数据关系，无法使用2003版。

                        斜阳几度在此谢过！！！

最佳答案

月排行榜 / 总排行榜

yorkchenshunan

2017-6-13 15:04

1. Sub caiji()
   
2. Dim n As Long, m As Long, arr, brr, i%, j%, k%, r%, crr(1 To 100000, 1 To 2), s As Boolean
   
3. Columns("d:e").ClearContents
   
4. arr = Range("a1:a100000")
   
5. brr = Range("b1:b16")
   
6.         m = 1
   
7. For i = 1 To 3
   
8.     For n = 1 To 100000 - 16 + i - 1
   
9.         r = 0
   
10.         For j = i To 16
    
11.                 If brr(j, 1) <> arr(j + n - i, 1) Then Exit For
    
12.                 r = r + 1
    
13.         Next
    
14.         If r = 16 - i + 1 Then
    
15.             If m > 1 Then
    
16.                 For k = 1 To m
    
17.                     If crr(k, 1) = 17 + n - i Then
    
18.                         s = True
    
19.                         Exit For
    
20.                     End If
    
21.                 Next
    
22.                 If Not s Then
    
23.                     crr(m, 1) = 17 + n - i
    
24.                     crr(m, 2) = arr(17 + n - i, 1)
    
25.                     m = m + 1
    
26.                 End If
    
27.                 s = False
    
28.             Else
    
29.                 crr(m, 1) = 17 + n - i
    
30.                 crr(m, 2) = arr(17 + n - i, 1)
    
31.                 m = m + 1
    
32.             End If
    
33.         End If
    
34.     Next
    
35. Next
    
36. Range("d1").Resize(m, 2) = crr
    
37. End Sub

复制代码

跳转到最佳答案楼层

yorkchenshunan

1. Sub caiji()
   
2. Dim n As Long, arr, brr, i%, j%, r%
   
3. arr = Range("a1:a100000")
   
4. brr = Range("b1:b16")
   
5. For i = 1 To 3
   
6.     For n = 1 To 100000 - 16 + i - 1
   
7.         r = 0
   
8.         For j = i To 16
   
9.                 If brr(j, 1) <> arr(j + n - i, 1) Then Exit For
   
10.                 r = r + 1
    
11.         Next
    
12.         If r = 16 - i + 1 Then
    
13.             Range("d100000").End(xlUp).Offset(1) = 17 + n - i
    
14.             Range("e100000").End(xlUp).Offset(1) = arr(17 + n - i, 1)
    
15.         End If
    
16.     Next
    
17. Next
    
18. End Sub

复制代码

斜阳几度

yorkchenshunan 发表于 2017-6-13 12:12

yorkchenshunan   你好

感谢你的帮助，你的代码我测试过了，非常好，运行快。

有三个问题：

1、每次运行程序都是重新开始，而不是累计采集数据。程序运行前D列和E列都是空的，用以添加新的数据。

2、每次运行程序，采集到的数据都从D1和E1开始记录，我现在看是从第二行开始记录。

3、是我的疏忽，没说清楚，采集后的数据有重复，也就是说第二次循环采集到的数据完全包括第一次循环采集的数据，第三次循环采集到的数据，完全包括前两次的数据。希望帮助改写一下代码，行数重复的数据不再采集。

希望高手能帮我修改一下代码？

感激！期盼中！！

yorkchenshunan

1. Sub caiji()
   
2. Dim n As Long, m As Long, arr, brr, i%, j%, k%, r%, crr(1 To 100000, 1 To 2), s As Boolean
   
3. Columns("d:e").ClearContents
   
4. arr = Range("a1:a100000")
   
5. brr = Range("b1:b16")
   
6.         m = 1
   
7. For i = 1 To 3
   
8.     For n = 1 To 100000 - 16 + i - 1
   
9.         r = 0
   
10.         For j = i To 16
    
11.                 If brr(j, 1) <> arr(j + n - i, 1) Then Exit For
    
12.                 r = r + 1
    
13.         Next
    
14.         If r = 16 - i + 1 Then
    
15.             If m > 1 Then
    
16.                 For k = 1 To m
    
17.                     If crr(k, 1) = 17 + n - i Then
    
18.                         s = True
    
19.                         Exit For
    
20.                     End If
    
21.                 Next
    
22.                 If Not s Then
    
23.                     crr(m, 1) = 17 + n - i
    
24.                     crr(m, 2) = arr(17 + n - i, 1)
    
25.                     m = m + 1
    
26.                 End If
    
27.                 s = False
    
28.             Else
    
29.                 crr(m, 1) = 17 + n - i
    
30.                 crr(m, 2) = arr(17 + n - i, 1)
    
31.                 m = m + 1
    
32.             End If
    
33.         End If
    
34.     Next
    
35. Next
    
36. Range("d1").Resize(m, 2) = crr
    
37. End Sub

复制代码

斜阳几度

yorkchenshunan 发表于 2017-6-13 15:04

太好了   完美的作品 ！！感谢你的帮助！！