[已解决]对称，相同提取。

left369

对称，相同提取。麻烦见附件，谢谢。

最佳答案

月排行榜 / 总排行榜

dsmch

2014-4-27 11:40

1. Sub Macro1()
   
2. Dim arr, brr, i&, j%, s&, y&, x&
   
3. arr = Range("b33").CurrentRegion
   
4. x = UBound(arr)
   
5. ReDim brr(1 To x, 1 To UBound(arr, 2) - 1)
   
6. For i = x To 1 Step -1
   
7.     s = x + 1 - i: y = i - s
   
8.     If y < 1 Then Exit For
   
9.     For j = 2 To UBound(arr, 2)
   
10.         If arr(i, j) = arr(y, j) Then brr(s, j - 1) = arr(i, j)
    
11.     Next
    
12. Next
    
13. Cells(x + 36, 2).Resize(s, UBound(brr, 2)) = brr
    
14. End Sub
    

复制代码

跳转到最佳答案楼层

su45

你检查下你的求助有没有问题，咱看不出规律来！

dsmch

1. Sub Macro1()
   
2. Dim arr, brr, i&, j%, s&, y&, x&
   
3. arr = Range("b33").CurrentRegion
   
4. x = UBound(arr)
   
5. ReDim brr(1 To x, 1 To UBound(arr, 2) - 1)
   
6. For i = x To 1 Step -1
   
7.     s = x + 1 - i: y = i - s
   
8.     If y < 1 Then Exit For
   
9.     For j = 2 To UBound(arr, 2)
   
10.         If arr(i, j) = arr(y, j) Then brr(s, j - 1) = arr(i, j)
    
11.     Next
    
12. Next
    
13. Cells(x + 36, 2).Resize(s, UBound(brr, 2)) = brr
    
14. End Sub
    

复制代码