用VBA在execl表格中，找出所有数字的字符恰好都出现两次的两个组合

一、要求

如图所示，我要从A、B、C三个区域中找出三个数据，使得这三个数据中的每一个字符组合起来之后，恰好每个字符都出现两次，去重后就只剩下三个字符

二、方法一：遍历单元格运行

优点就是可以设置相同一组的颜色相同，缺点就是运行时间太久了，要180多秒

代码：

Sub 提出都出现两次的数据()
    Dim a, b, c, t, i
    t = Timer
    Dim rng1, rng2, rng3, rng4, rng5
    Dim str As String
    Dim arr
    Dim NO1 As Boolean
    For i = 5 To 100
        Set rng1 = Range(Cells(i, 5), Cells(i, 8))
        Set rng2 = Range(Cells(i, 10), Cells(i, 13))
        Set rng3 = Range(Cells(i, 15), Cells(i, 18))
        Set rng4 = Range(Cells(i, 19), Cells(i, 22))
        Set rng5 = Range(Cells(i, 24), Cells(i, 27))
        
        For Each a In rng1
            For Each b In rng2
                For Each c In rng3
                    str = a.Value & b.Value & c.Value
                    arr = StringToArray(str)
                    arr = 一维数组去重(arr)
                    If UBound(arr) = 2 Then
                        If NO1 Then
                            a.Interior.ColorIndex = 4
                            b.Interior.ColorIndex = 4
                            c.Interior.ColorIndex = 4
                            rng4.Cells(1) = a
                            rng4.Cells(2) = b
                            rng4.Cells(3) = c
                            rng4.Cells(4) = arr(0) & arr(1) & arr(2)
                            NO1 = False
                        Else
                            a.Interior.ColorIndex = 3
                            b.Interior.ColorIndex = 3
                            c.Interior.ColorIndex = 3
                            rng5.Cells(1) = a
                            rng5.Cells(2) = b
                            rng5.Cells(3) = c
                            rng5.Cells(4) = arr(0) & arr(1) & arr(2)
                            NO1 = True
                        End If
                    End If
                Next
            Next
        Next
    Next i
    MsgBox "运行时间（秒）：" & Timer - t
End Sub
 
Function 一维数组去重(arr)
    Dim i&, s, keys
    Dim dic
    Set dic = CreateObject("scripting.dictionary")
    For i = LBound(arr) To UBound(arr) '去重
        If arr(i) <> "" Then
            If Not dic.Exists(arr(i)) Then dic.Add arr(i), Nothing
        End If
    Next
    ReDim arr(0 To dic.count - 1)
    keys = dic.keys
    For i = 0 To dic.count - 1
        arr(i) = keys(i)
    Next
    一维数组去重 = arr
End Function
Function StringToArray(str As String)
    Dim rr() As String
    Dim i As Integer
    
    ReDim rr(1 To Len(str))
    
    For i = 1 To Len(str)
        rr(i) = Mid(str, i, 1)
    Next i
    
    StringToArray = rr
End Function

三、方法二：用数组

优点就是快，只要14秒。缺点就是不能设置同一组类型的单元格颜色

代码：

Sub 提出都出现两次的数据_数组版()
    Application.ScreenUpdating = False '关闭屏幕刷新
    Dim t
    t = Timer
    Dim SZ0, SZ1
    Dim index As Integer
    Dim str As String
    
    SZ0 = Range(Cells(4, 5), Cells(100, 18))
    ReDim SZ1(1 To UBound(SZ0), 1 To 9)
    For index = 1 To UBound(SZ0)
        For i = 1 To 4
            For j = 6 To 9
                For k = 11 To 14
                    str = SZ0(index, i) & SZ0(index, j) & SZ0(index, k)
                    arr = StringToArray(str)
                    arr = 一维数组去重(arr)
                    If UBound(arr) = 2 Then
                        If NO1 Then
                            SZ1(index, 1) = SZ0(index, i)
                            SZ1(index, 2) = SZ0(index, j)
                            SZ1(index, 3) = SZ0(index, k)
                            SZ1(index, 4) = arr(0) & arr(1) & arr(2)
                            NO1 = False
                            goto x
                        Else
                            SZ1(index, 6) = SZ0(index, i)
                            SZ1(index, 7) = SZ0(index, j)
                            SZ1(index, 8) = SZ0(index, k)
                            SZ1(index, 9) = arr(0) & arr(1) & arr(2)
                            NO1 = True
                        End If
                    End If
                Next
            Next
        Next
x:
    Next index
    Range("s4").Resize(UBound(SZ1), 9) = SZ1
    Range("s4").Resize(UBound(SZ1), 9).NumberFormat = "000"
    Range("s4").Resize(UBound(SZ1), 3).NumberFormat = "00"
    Range("x4").Resize(UBound(SZ1), 3).NumberFormat = "00"
    Application.ScreenUpdating = True
    MsgBox "运行时间（秒）：" & Timer - t
End Sub
Function 一维数组去重(arr)
    Dim i&, s, keys
    Dim dic
    Set dic = CreateObject("scripting.dictionary")
    For i = LBound(arr) To UBound(arr) '去重
        If arr(i) <> "" Then
            If Not dic.Exists(arr(i)) Then dic.Add arr(i), Nothing
        End If
    Next
    ReDim arr(0 To dic.count - 1)
    keys = dic.keys
    For i = 0 To dic.count - 1
        arr(i) = keys(i)
    Next
    一维数组去重 = arr
End Function
Function StringToArray(str As String)
    Dim rr() As String
    Dim i As Integer
    
    ReDim rr(1 To Len(str))
    
    For i = 1 To Len(str)
        rr(i) = Mid(str, i, 1)
    Next i
    
    StringToArray = rr
End Function