|
Sub 按钮1_Click()
Dim arr()
[a1].CurrentRegion.Offset(1).Clear
Set d = CreateObject("scripting.dictionary")
ReDim arr(1 To [f2], 1 To 2)
For j = 1 To [f2]
If d.Count = 3 Then
d.Remove d.keys()(0)
End If
l1:
x = WorksheetFunction.RandBetween([d2], [e2])
If d.exists(x) Then GoTo l1
arr(j, 1) = x
d(x) = ""
Next j
d.RemoveAll
For j = UBound(arr) To 3 Step -1
str1 = ""
For i = j - 2 To j
str1 = str1 & arr(i, 1)
Next i
arr(j, 2) = str1
If Not d.exists(str1) Then
Set d(str1) = Cells(j + 1, 2)
Else
Set d(str1) = Union(d(str1), Cells(j + 1, 2))
End If
Next j
For Each k In d.keys
If d(k).Cells.Count > 1 Then d(k).Interior.ColorIndex = 3
Next k
[a2].Resize(UBound(arr), 2) = arr
End Sub
|
|