試試VBA, 請貼在工作表"201412-1"(不是Modula1)
Sub test()
Dim sh As Worksheet
Dim I As Integer, Lst As Integer
Dim d, Rng As Range, E, Cnt
Set d = CreateObject("Scripting.Dictionary")
Set sh = Sheets("工作表1")
Lst = Range("A" & Rows.Count).End(xlUp).Row
Set Rng = [A2].Resize(Lst - 1, 1)
sh.Cells.Clear '清除"工作表1"
For Each E In Rng
d.Item(E.Value) = "" '用 Dictionary 的不重覆性篩選"號碼"
Next
sh.[A2].Resize(d.Count) = Application.Transpose(d.Keys) '複製"不重覆號碼" 到 "工作表1"
Set Rng = sh.[A2].Resize(d.Count, 1)
ReDim Cnt(1 To d.Count) As Integer
For I = 2 To Lst
MH = Application.Match(Cells(I, 1), Rng)
If Application.IsNumber(MH) Then
Cnt(MH) = Cnt(MH) + 1
sh.Cells(MH + 1, Cnt(MH) + 1) = Cells(I, 1).Offset(0, 1)
End If
Next
End Sub作者: 准提部林 時間: 2016-2-25 20:38
Sub TEST()
Dim Arr, Brr, T$, N&, xD, Dr, X%, i&
Arr = Range([A1], Cells(Rows.Count, 2).End(xlUp))
ReDim Brr(1 To UBound(Arr), 1 To 200)
Set xD = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(Arr)
If Arr(i, 1) = "" Or Arr(i, 2) = "" Then GoTo 101
T = Arr(i, 1): Dr = xD(T)
If Not IsArray(Dr) Then N = N + 1: Dr = Array(N, 0): Brr(N, 1) = T
Dr(1) = Dr(1) + 1: If Dr(1) > X Then X = Dr(1)
Brr(Dr(0), Dr(1) + 1) = Arr(i, 2): xD(T) = Dr
101: Next i
With [工作表1!A1].Resize(N + 1, X + 1)
.Parent.UsedRange.Clear
.Cells(2, 1).Resize(N, X + 1) = Brr
.Item(1) = Arr(1, 1)
.Item(2).Resize(1, X) = "=""" & Arr(1, 2) & "-""&COLUMN(a1)"
.Borders.LineStyle = 1
Application.Goto .Item(1)
End With
End Sub
當初應該要去學寫程式的)