- 帖子
- 2848
- 主題
- 10
- 精華
- 0
- 積分
- 2903
- 點名
- 0
- 作業系統
- 〔略〕
- 軟體版本
- 〔略〕
- 閱讀權限
- 100
- 性別
- 男
- 來自
- 〔略〕
- 註冊時間
- 2013-5-13
- 最後登錄
- 2026-7-25
|
回復 6# leiru
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
Xl0000397.rar (30.75 KB)
|
|