求一个把上下2行相同的数字提出来的VBA,谢谢

gwjkkkkk

Option Explicit
Sub TEST2()
    Dim ar, br, i&, j&, n&, r&, iColSize&, strJoin$
   
    Application.ScreenUpdating = False
   
    r = Cells(Rows.Count, "B").End(xlUp).Row
    ar = Range("B2:U" & r).Value
    ReDim br(1 To UBound(ar), 1 To UBound(ar, 2))
   
    For i = 2 To UBound(ar)
        strJoin = "," & Join(Application.Index(ar, i - 1), ",") & ","
        n = 0
        For j = 1 To UBound(ar, 2)
            If InStr(strJoin, "," & ar(i, j) & ",") Then
                n = n + 1
                br(i, n) = ar(i, j)
            End If
        Next j
        If n > iColSize Then iColSize = n
    Next i
   
    [W2].Resize(UBound(br), iColSize) = br
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

..........

今铭昔

sdytsxd991122

usedrange

1. Sub tt()
   
2.     Dim ar, i%, j%, br, dic, r%, c%
   
3.     Set dic = CreateObject("scripting.dictionary")
   
4.     ar = Sheet2.[b2].Resize(7, 21)
   
5.     ReDim br(1 To UBound(ar), 1 To 14)
   
6.     r = 1
   
7.     For i = 1 To UBound(ar)
   
8.         c = 1
   
9.         For j = 1 To UBound(ar, 2)
   
10.             dic(ar(i, j)) = ""
    
11.         Next j
    
12.         If i + 1 <= UBound(ar) Then
    
13.             For j = 1 To UBound(ar, 2)
    
14.                 If dic.exists(ar(i + 1, j)) Then
    
15.                     br(r, c) = ar(i + 1, j): c = c + 1
    
16.                 End If
    
17.             Next j
    
18.         End If
    
19.         dic.RemoveAll
    
20.         r = r + 1
    
21.     Next i
    
22.     [w3].Resize(UBound(br), 14) = br
    
23.     Set dic = Nothing
    
24. End Sub
    
25. 
    

复制代码

boy8199

思路:如果是一次性的,就用lookup查找,找到了就等于那个数,没有就等于零,然后删除0.