求助数据组合问题内容在附件

zhenghui13

不知道是不是这个样子.

1. 
   
2. Sub Match_1()
   
3. Dim t
   
4. Dim Arr, a
   
5. Dim Brr, b
   
6. Dim Crr, c
   
7. t = Timer
   
8. With Sheet1
   
9. Arr = .Cells(1, 2).CurrentRegion
   
10. Brr = .Cells(1, 6).CurrentRegion
    
11. ReDim Crr(1 To UBound(Arr) * UBound(Brr), 1 To 5)
    
12. a = 1: b = 1: c = 0
    
13. Do While a < UBound(Arr)
    
14.     b = 1
    
15.     Do While b < UBound(Brr)
    
16.         If Arr(a, 3) = Brr(b, 1) Then
    
17.             c = c + 1
    
18.             Crr(c, 1) = Arr(a, 1): Crr(c, 2) = Arr(a, 2): Crr(c, 3) = Arr(a, 3)
    
19.             Crr(c, 4) = Brr(b, 2): Crr(c, 5) = Brr(b, 3)
    
20.         End If
    
21.         b = b + 1
    
22.     Loop
    
23.     a = a + 1
    
24. Loop
    
25. .Columns("J:N").ClearContents
    
26. .Cells(1, 10).Resize(c, 5) = Crr
    
27. End With
    
28. MsgBox (Timer - t)
    
29. End Sub
    

复制代码

三票

zhenghui13 发表于 2018-7-12 14:09
不知道是不是这个样子.

是这样的结果，附件中第二个条件的代码也是这个吗

zhenghui13

三票 发表于 2018-7-12 14:22
是这样的结果，附件中第二个条件的代码也是这个吗

第二个我没有做，如果条件相同，你按这个代码修改一下即可。

三票

zhenghui13 发表于 2018-7-12 14:25
第二个我没有做，如果条件相同，你按这个代码修改一下即可。

麻烦您改一下，我对代码基本上不懂。谢谢

zhenghui13

三票 发表于 2018-7-12 14:27
麻烦您改一下，我对代码基本上不懂。谢谢

Here you are.

三票

zhenghui13 发表于 2018-7-12 14:41
Here you are.

非常感您，谢谢

zhenghui13

不客户，也许你可以将[求助]改成[已解决]

三票

zhenghui13 发表于 2018-7-12 14:48
不客户，也许你可以将[求助]改成[已解决]

数据从第三行开始的，代码怎么改啊