|
Option Explicit
Sub TEST()
Dim ar, br, vResult, i&, j&, r&, k&, dic As Object, vKey, iPosRow
Application.ScreenUpdating = False
Set dic = CreateObject("Scripting.Dictionary")
ar = Range("B4", [B4].End(xlDown)).Resize(, 4)
ReDim vResult(1 To 10 ^ 4, 1 To UBound(ar, 2))
For j = 1 To UBound(ar, 2)
dic.RemoveAll: r = 0
For i = 1 To UBound(ar)
br = Split(ar(i, j), "、")
For k = 0 To UBound(br)
dic(br(k)) = dic(br(k)) + 1
Next k
Next i
For Each vKey In dic.keys
r = r + 1
vResult(r, j) = vKey & dic(vKey) & "次"
Next
If r > iPosRow Then iPosRow = r
Next j
With [B34].Resize(iPosRow, UBound(vResult, 2))
.Value = vResult
.HorizontalAlignment = xlCenter
.Borders.LineStyle = xlContinuous
.Font.Size = 9
End With
Set dic = Nothing
Application.ScreenUpdating = True
Beep
End Sub
|
|