麻烦写个交集代码

不可说7625

取A1到L1都出现的值。在N1显示结果。


用按钮运行。谢谢。

ykcbf1100

附件供参考。。。

ykcbf1100

1. Sub ykcbf()  '//2025.3.26
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     arr = [a1:l1].Value
   
5.     For j = 1 To UBound(arr, 2)
   
6.         n = n + 1
   
7.         st = Split(arr(1, j))
   
8.         For Each k In st
   
9.             d(CStr(k)) = d(CStr(k)) + 1
   
10.         Next
    
11.     Next
    
12.     For Each k In d.keys
    
13.         t = d(k)
    
14.         If t = n Then tt = tt & " " & k
    
15.     Next
    
16.     [n1] = Mid(tt, 2)
    
17.     Set d = Nothing
    
18.     Application.ScreenUpdating = True
    
19.     MsgBox "OK！"
    
20. End Sub
    
21. 
    

复制代码

quqiyuan

参与一下，仅供参考。。。

quqiyuan

代码如下。。。
Sub test()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    t = Timer
    Dim wb As Workbook, sht As Worksheet, sh As Worksheet
    Set wb = ThisWorkbook
    Set sht = wb.Sheets("sheet1")
    arr = sht.[a1:l1]
    s = Split(arr(1, 1))
    Set d = CreateObject("scripting.dictionary")
    For i = 0 To UBound(s)
        If Not d.exists(s(i)) Then
            n = n + 1
            d(s(i)) = n
        End If
    Next
    ReDim brr(1 To 1)
    For i = 2 To UBound(arr, 2)
        n = 0
        s = Split(arr(1, i))
        For j = 0 To UBound(s)
            If d.exists(s(j)) Then
                n = n + 1
                ReDim Preserve brr(1 To n)
                brr(n) = s(j)
            End If
        Next
        d.RemoveAll
        For k = 1 To n
            If Not d.exists(brr(k)) Then
                d(brr(k)) = ""
            End If
        Next
    Next
    sht.[n1] = Trim(Join(d.keys))
    sht.[n1].WrapText = True
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "共耗时：" & Format(Timer - t, "0.0000") & " 秒！！！", 64
End Sub

今铭昔

cjc209

翁知江安

Sub test()
Dim j, k, x, t
Dim ar, tepar As Variant
Dim d As Object
Set d = CreateObject("scripting.dictionary")
ar = Sheet1.[a1].CurrentRegion
For j = 1 To UBound(ar, 2)
  tepar = Split(ar(1, j), " ")
  For Each x In tepar
  If Len(x) > 0 Then
  d(x) = d(x) + 1
  End If
  Next
Next
t = ""
For Each k In d.keys
   If d(k) = UBound(ar, 2) Then
   t = t & k & " "
   End If
Next
Sheet1.[n1].ClearContents
Sheet1.[n1] = t
End Sub

翁知江安

供参考，欢迎批评指正

sdytsxd991122