求助~拆解Cell欄位

帖子: 163
主題: 1
精華: 0
積分: 170
點名: 0
作業系統: Window 7
軟體版本: Office 2007
閱讀權限: 20
性別: 男
註冊時間: 2010-9-5
最後登錄: 2022-7-20

4^# 跳轉到 »

發表於 2014-5-7 09:39 | 只看該作者

回復 3# tommy.lin

拆解來源為A、B欄，
拆解後寫入C、D欄。
Option Base 1
Sub test()
Dim arr1, arr2
Dim brr()
er = [A65536].End(3).Row
arr1 = Range("A2:B" & er)
ActiveSheet.Columns(2).Replace "/", ";"
arr2 = Range("A2:B" & er)
For i = 1 To UBound(arr2)
      For j = 0 To UBound(Split(arr2(i, 2), ";"))
         n = n + 1
         ReDim Preserve brr(2, n)
         If j = 0 Then brr(1, n) = arr2(i, 1)
         brr(2, n) = Split(arr2(i, 2), ";")(j)
      Next j
Next i
[C2:D65536].ClearContents
[C2].Resize(UBound(brr, 2), 2) = Application.Transpose(brr)
Range("A2:B" & er) = arr1
arr1 = ""
arr2 = ""
Erase brr
End Sub

[b]Kubi[/b]

TOP

tommy.lin