Excel VBA 將區域中的重復文本計數並排列

選擇好妳要的區域，再運行此代碼即可

Dim?arr,?brr(),?x%,?y%,?i%,?j%

Dim?d?As?Object,?k

Set?d?=?CreateObject("scripting.dictionary")

arr?=?Selection

For?x?=?1?To?UBound(arr)

For?y?=?1?To?UBound(arr,?2)

If?Not?d.exists(arr(x,?y))?Then

i?=?i?+?1

d(arr(x,?y))?=?i

ReDim?Preserve?brr(1?To?2,?1?To?i)

brr(1,?i)?=?arr(x,?y)

End?If

brr(2,?d(arr(x,?y)))?=?brr(2,?d(arr(x,?y)))?+?1

Next?y

Next?x

For?x?=?1?To?UBound(brr,?2)?-?1

For?y?=?x?+?1?To?UBound(brr,?2)

If?brr(2,?x)?<?brr(2,?y)?Then

For?j?=?1?To?2

k?=?brr(j,?x)

brr(j,?x)?=?brr(j,?y)

brr(j,?y)?=?k

Next?j

End?If

Next?y

Next?x

Sheet2.Range("A1").Resize(UBound(brr,?2),?1)?=?Application.Transpose(brr)

End?Sub