用函数太难了,用代码吧,如图对A列进行排列
代码如下:
Sub 排序()
Dim i%, j%, m%, n%, k, arr, brr(), crr(), d As Object
i = 2
Do Until i >= [a1].End(4).Row
Set d = CreateObject("scripting.dictionary")
arr = Range("a" & i, "a" & i + 2)
For j = 1 To 3
If Not d.exists(arr(j, 1)) Then
d(arr(j, 1)) = 1
Else
d(arr(j, 1)) = d(arr(j, 1)) + 1
End If
Next
k = d.keys
For m = 0 To UBound(k)
ReDim Preserve brr(1 To m + 1)
brr(m + 1) = k(m) & IIf(d(k(m)) = 3, "", d(k(m)) & "/3")
Next
n = n + 1
ReDim Preserve crr(1 To n)
crr(n) = VBA.Join(brr(), ",")
Set d = Nothing
i = i + 3
Loop
[b2].Resize(n) = Application.Transpose(crr)
End Sub
代码如下:
Sub 排序()
Dim i%, j%, m%, n%, k, arr, brr(), crr(), d As Object
i = 2
Do Until i >= [a1].End(4).Row
Set d = CreateObject("scripting.dictionary")
arr = Range("a" & i, "a" & i + 2)
For j = 1 To 3
If Not d.exists(arr(j, 1)) Then
d(arr(j, 1)) = 1
Else
d(arr(j, 1)) = d(arr(j, 1)) + 1
End If
Next
k = d.keys
For m = 0 To UBound(k)
ReDim Preserve brr(1 To m + 1)
brr(m + 1) = k(m) & IIf(d(k(m)) = 3, "", d(k(m)) & "/3")
Next
n = n + 1
ReDim Preserve crr(1 To n)
crr(n) = VBA.Join(brr(), ",")
Set d = Nothing
i = i + 3
Loop
[b2].Resize(n) = Application.Transpose(crr)
End Sub