求助~拆解Cell欄位

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

2^#

發表於 2014-5-7 08:44 | 只看該作者

回復 1# tommy.lin

試看看。
檔案下載：http://ge.tt/2cokpIg1/v/0?c

[b]Kubi[/b]

帖子: 24
主題: 6
精華: 0
積分: 35
點名: 0
作業系統: WIN7
軟體版本: Office 2010
閱讀權限: 10
性別: 男
來自: Taipei
註冊時間: 2012-3-19
最後登錄: 2015-1-8

3^#

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

好像需要申請帳號才可以下載是?

Kubi

帖子: 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]

帖子: 24
主題: 6
精華: 0
積分: 35
點名: 0
作業系統: WIN7
軟體版本: Office 2010
閱讀權限: 10
性別: 男
來自: Taipei
註冊時間: 2012-3-19
最後登錄: 2015-1-8

5^#

發表於 2014-5-7 11:50 | 只看該作者

可以了~~ 感謝喔~~
怎麼樣練習可以變這麼強?
還是有地方可以上課?

帖子: 24
主題: 6
精華: 0
積分: 35
點名: 0
作業系統: WIN7
軟體版本: Office 2010
閱讀權限: 10
性別: 男
來自: Taipei
註冊時間: 2012-3-19
最後登錄: 2015-1-8

6^#

發表於 2014-5-7 13:33 | 只看該作者

Hi Kubi:
又如果我的資料拆解來源是A & D 欄位我要如何修改VB 變成我想要的?

Regards
Tommy

Kubi

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

7^#

發表於 2014-5-7 14:15 | 只看該作者

回復 6# tommy.lin

資料拆解來源是A & D 欄....
可否請版大附上如#1的圖形，以方便了解所需。

[b]Kubi[/b]

帖子: 24
主題: 6
精華: 0
積分: 35
點名: 0
作業系統: WIN7
軟體版本: Office 2010
閱讀權限: 10
性別: 男
來自: Taipei
註冊時間: 2012-3-19
最後登錄: 2015-1-8

8^#

發表於 2014-5-7 15:31 | 只看該作者

Hi Kubi:
不好意思~初學者問題太多@@"希望沒造成你困擾

Regards
Tommy

Kubi

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

9^#

發表於 2014-5-7 19:37 | 只看該作者

回復 8# tommy.lin

檔案下載：http://ge.tt/5PcoXKg1/v/0?c

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

[b]Kubi[/b]

帖子: 24
主題: 6
精華: 0
積分: 35
點名: 0
作業系統: WIN7
軟體版本: Office 2010
閱讀權限: 10
性別: 男
來自: Taipei
註冊時間: 2012-3-19
最後登錄: 2015-1-8

10^#

發表於 2014-5-8 09:21 | 只看該作者

Hi Kubi:
測試可以使用
感謝你的幫忙..

有空假日可以個別教學?@@"

Regards