
'凑了一个,应该会有2种或更多结果的,条件不是很明确
Option Explicit
Sub abc()
Dim a, i, j, t, key, m, d
a = [a1].CurrentRegion.Resize(, 1).Value
Set d = CreateObject("scripting.dictionary")
Call bsort(a, 1, UBound(a), 1, 1, 1)
For i = 1 To UBound(a)
If d.exists(a(i, 1)) Then
d(a(i, 1)) = d(a(i, 1)) & Space(1) & a(i, 1)
Else
t = right(a(i, 1), 1) & left(a(i, 1), 1)
If d.exists(t) Then
d(t) = d(t) & Space(1) & a(i, 1)
Else
d(a(i, 1)) = d(a(i, 1)) & Space(1) & a(i, 1)
End If
End If
Next
For Each key In d.keys
t = Split(d(key))
For i = 1 To UBound(t)
m = m + 1: a(m, 1) = t(i)
Next
Next
[c1].Resize(UBound(a)) = a
End Sub
Function bsort(a, first, last, left, right, key)
Dim i, j, k, t
For i = first To last - 1
For j = first To last + first - 1 - i
If StrComp(a(j, key), a(j + 1, key), vbTextCompare) = 1 Then
For k = left To right
t = a(j, k): a(j, k) = a(j + 1, k): a(j + 1, k) = t
Next
End If
Next
Next
End Function