Option Explicit
Sub TEST()
Dim xU As Range, Crr, A As Range, Z, T$, T1$, T2$, R&, N&, i&, j%
Set Z = CreateObject("Scripting.Dictionary")
Set xU = Range([C2], [C65536].End(xlUp)).SpecialCells(xlCellTypeVisible)
ReDim Crr(1 To 10000, 1 To 3)
For Each A In xU: Z(Trim(A)) = Z(Trim(A)) + 1: Next
For Each A In xU
T1 = Trim(A): T2 = Trim(A(1, 2)): T = T1 & "|" & T2
If Z(T1) = 1 Or T1 = "" Then GoTo i01 Else R = Z(T)
If R = 0 Then N = N + 1: R = N: Z(T) = R: Crr(R, 1) = "'" & T1: Crr(R, 2) = T2
Crr(R, 3) = Crr(R, 3) + 1
i01: Next
If N = 0 Then Exit Sub
With Workbooks.Add.Sheets(1)
.[A1].Resize(1, 3) = [{"關鍵字1","關鍵字2","次數"}]
.[A2].Resize(N, 3) = Crr
.Columns(1).EntireColumn.AutoFit
.Cells.Sort KEY1:=.Cells(1), Order1:=1, Key2:=.Cells(2), Order2:=1, Header:=1
For i = 2 To .[A65536].End(3).Row
j = j - (.Cells(i, 1) <> .Cells(i - 1, 1))
.Cells(i, 1).Interior.ColorIndex = j Mod 15 + 33
Next
End With
End Sub作者: cypd 時間: 2023-12-28 14:57
