一、要求
如图所示,我要从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