[已解决]数据匹配后产生新的数据

tjxyxj888

求助：下总共三组数据（在实际中是随机产生，三组数据不等，实际中每组数据大约在450个），以第一组数据为基数，在第二组中寻找符合第一组数据的第2位和第3位进行匹配，匹配后会产生一个4位数，这个4位数的第3位第4位再和第3组数据进行匹配，会产生一个5位数，并以此排列。

举例:第一组017对应第二组17*的数据。0170,0172,0173等等。0170对应第三组数据70开始的数据，会产生一组5位数：01701，01702,01703等等

最佳答案

月排行榜 / 总排行榜

心正意诚身修

2021-12-8 17:24

1. Sub 数据生成()
   
2. Dim newarr(), ar As Integer, br As Integer, cr As Integer, a As Integer, b As Integer, c As Integer
   
3. Dim aa As String, bb As String, cc As String, k As Byte
   
4. Range("e2:CA10000").ClearContents
   
5. ar = Range("a65536").End(xlUp).Row
   
6. ReDim newarr(1 To ar - 1, 1 To 200)
   
7. For a = 2 To ar
   
8.     If Range("a" & a) = "" Then
   
9.     a = a + 1
   
10.     End If
    
11.    
    
12.     aa = Mid(Range("a" & a), 2, 2)
    
13.     On Error Resume Next
    
14.     br = Application.Match(aa & "*", Range("b1:b65536"), 0)
    
15.     Do While aa = Mid(Range("b" & br), 1, 2)
    
16.     bb = Mid(Range("b" & br), 2, 2)
    
17.     cr = Application.Match(bb & "*", Range("c1:c65536"), 0)
    
18.     Do While bb = Mid(Range("c" & cr), 1, 2)
    
19.         k = k + 1
    
20.             newarr(a - 1, k) = Mid(Range("A" & a), 1, 3) & Mid(Range("c" & cr), 2, 2)
    
21.         cr = cr + 1
    
22.     Loop
    
23.        br = br + 1
    
24.     Loop
    
25.     k = 0
    
26. Next
    
27. Range("e2").Resize(a - 2, 200) = newarr
    
28. End Sub
    
29. 
    

复制代码

跳转到最佳答案楼层

心正意诚身修

............

hcm19522

猜看看   
D2 下拉{=INDEX(A:A,INT(SMALL(IF(RIGHT(A$2:A$482,2)=TRANSPOSE(LEFT(B$2:B$482,2)),ROW($2:$482)/1%%+TRANSPOSE(ROW($2:$482))),ROW(A1))/10000))&RIGHT(INDEX(B:B,RIGHT(SMALL(IF(RIGHT(A$2:A$482,2)=TRANSPOSE(LEFT(B$2:B$482,2)),ROW($2:$482)/1%%+TRANSPOSE(ROW($2:$482))),ROW(A1)),4)))

心正意诚身修

1. Sub 数据生成()
   
2. Dim newarr(), ar As Integer, br As Integer, cr As Integer, a As Integer, b As Integer, c As Integer
   
3. Dim aa As String, bb As String, cc As String, k As Byte
   
4. Range("e2:CA10000").ClearContents
   
5. ar = Range("a65536").End(xlUp).Row
   
6. ReDim newarr(1 To ar - 1, 1 To 200)
   
7. For a = 2 To ar
   
8.     If Range("a" & a) = "" Then
   
9.     a = a + 1
   
10.     End If
    
11.    
    
12.     aa = Mid(Range("a" & a), 2, 2)
    
13.     On Error Resume Next
    
14.     br = Application.Match(aa & "*", Range("b1:b65536"), 0)
    
15.     Do While aa = Mid(Range("b" & br), 1, 2)
    
16.     bb = Mid(Range("b" & br), 2, 2)
    
17.     cr = Application.Match(bb & "*", Range("c1:c65536"), 0)
    
18.     Do While bb = Mid(Range("c" & cr), 1, 2)
    
19.         k = k + 1
    
20.             newarr(a - 1, k) = Mid(Range("A" & a), 1, 3) & Mid(Range("c" & cr), 2, 2)
    
21.         cr = cr + 1
    
22.     Loop
    
23.        br = br + 1
    
24.     Loop
    
25.     k = 0
    
26. Next
    
27. Range("e2").Resize(a - 2, 200) = newarr
    
28. End Sub
    
29. 
    

复制代码