- Sub Macro1()
- On Error Resume Next
- Dim w, dic, a%, b%, c%, d%, e%, f%, s&
- Set dic = CreateObject("scripting.dictionary")
- w = [a1:ae1]
- n = UBound(w, 2)
- For a = 1 To n - 5
- For b = a + 1 To n - 4
- For c = b + 1 To n - 3
- For d = c + 1 To n - 2
- For e = d + 1 To n - 1
- For f = e + 1 To n
- For i = 1 To 3
- a1 = Mid(w(1, a), i, 1)
- b1 = Mid(w(1, b), i, 1)
- c1 = Mid(w(1, c), i, 1)
- d1 = Mid(w(1, d), i, 1)
- e1 = Mid(w(1, e), i, 1)
- f1 = Mid(w(1, f), i, 1)
- dic(a1) = dic(a1) + 1
- dic(b1) = dic(b1) + 1
- dic(c1) = dic(c1) + 1
- dic(d1) = dic(d1) + 1
- dic(e1) = dic(e1) + 1
- dic(f1) = dic(f1) + 1
- Next
- If Join(dic.items, "") = String(9, "2") Then
- s = s + 1
- Cells(s + 2, 1) = w(1, a)
- Cells(s + 2, 2) = w(1, b)
- Cells(s + 2, 3) = w(1, c)
- Cells(s + 2, 4) = w(1, d)
- Cells(s + 2, 5) = w(1, e)
- Cells(s + 2, 6) = w(1, f)
- End If
- dic.RemoveAll
- Next
- Next
- Next
- Next
- Next
- Next
- End Sub
复制代码 |