Dim?sh?As?Worksheet,?rg?As?Range,?rg0?As?Range,?rg1?As?Range
Dim?a,?i,?d,?dC,?dD,?tmp
Set?d?=?CreateObject("Scripting.Dictionary")
Set?dC?=?CreateObject("Scripting.Dictionary")
Set?dD?=?CreateObject("Scripting.Dictionary")
Set?sh?=?ActiveSheet
With?sh
Set?rg0?=?.Range("A:D")?'原數據列位置
Set?rg1?=?.Range("E1")'結果數據，第壹個單元格位置
Set?rg?=?Application.Intersect(rg0,?.UsedRange)
If?rg?Is?Nothing?Then?MsgBox?"無數據！",?vbCritical:?Exit?Sub
If?rg.Rows.Count?<?2?Or?rg.Columns.Count?<>?4?Then
MsgBox?"數據設置錯誤！",?vbCritical:?Exit?Sub
End?If
End?With
a?=?rg
For?i?=?1?To?UBound(a)
tmp?=?Trim(a(i,?2))
If?tmp?<>?""?Then
If?d.Exists(tmp)?Then
d(tmp)?=?d(tmp)?&?"?"?&?a(i,?1)
Else
d(tmp)?=?a(i,?1)
dC(tmp)?=?a(i,?3)
dD(tmp)?=?a(i,?4)
End?If
End?If
Next
If?d.Count?<?2?Then?MsgBox?"無數據！",?vbCritical:?Exit?Sub
With?rg1.Resize(d.Count,?4)
.EntireColumn.ClearContents
.Columns(1)?=?Application.Transpose(d.items)
.Columns(2)?=?Application.Transpose(d.keys)
.Columns(3)?=?Application.Transpose(dC.items)
.Columns(4)?=?Application.Transpose(dD.items)
End?With
End?Sub