Sub 重整()
Dim Arr, Brr, A, B, xD, i&, j%, N&, T$
[I2:L6000].Clear
Set xD = CreateObject("Scripting.Dictionary")
Arr = Range([G2], [F65536].End(xlUp))
For i = 1 To UBound(Arr)
xD(Arr(i, 1) & "") = Arr(i, 2)
Next i
Arr = Range([C2], [A65536].End(xlUp))
ReDim Brr(1 To 20000, 1 To 4)
For i = 1 To UBound(Arr)
A = Split(Replace(Arr(i, 2), ChrW(160), ""), "、")
B = Split(Replace(Arr(i, 3), ChrW(160), ""), "、")
If UBound(A) <> UBound(B) Then MsgBox "第 " & i + 1 & " 行數據有問題!! ": Exit Sub
For j = 0 To UBound(A)
N = N + 1: T = T & "、" & xD(B(j) & "")
Brr(N, 1) = Arr(i, 1): Brr(N, 2) = A(j)
Brr(N, 3) = B(j): Brr(N, 4) = xD(B(j) & "")
Next j
Arr(i, 1) = Mid(T, 2): T = ""
Next i
With [I2].Resize(N, 4)
.Columns(2).NumberFormatLocal = "#,##0 ;-#,##0 "
.Columns(3).HorizontalAlignment = xlCenter
.Columns(4).NumberFormatLocal = "@"
.Borders.LineStyle = 1: .Font.Size = 10
.Value = Brr
End With
[D2].Resize(UBound(Arr)) = Arr '填入D欄對應值
End Sub