(EXCEL)請教在同一欄內數值如何分解對應

[lys338]

試問以下問題(*表示區隔,沒有意義,不然兩欄的數字會連在一起)
*********欄A ********************欄B
列1***** A123456789************C123,C456,C789,C741,
列2*****Q879654321************B123,B963,B999,B963,
列3****************************B785,B852,B147,
列4*****P987654321************R12,R33,R77,R45,R96,
列5***************************R68,R44,R66,R87,
列6***** P852741963************C987,C456,C841,C123,

如何轉成

欄E ************欄F
C123***********A123456789
C456***********A123456789
C789***********A123456789
C741***********A123456789
B123***********Q879654321
B963***********Q879654321
B999***********Q879654321
B963***********Q879654321
B785***********Q879654321
B852***********Q879654321
B147***********Q879654321
R12************P987654321
R33************P987654321
R77************P987654321
R45************P987654321
R96************P987654321
R68************P987654321
R44************P987654321
R66************P987654321
R87************P987654321
C987***********P852741963
C456***********P852741963
C841***********P852741963
C123***********P852741963

進而可以將相同之開頭(以下循E欄為例)歸納排列

欄G****************欄H
C123***********A123456789
C123***********P852741963
C456***********A123456789
C456***********P852741963
C741***********A123456789
C789***********A123456789
C841***********P852741963
C987***********P852741963

B123***********Q879654321
B147***********Q879654321
B785***********Q879654321
B852***********Q879654321
B963***********Q879654321
B999***********Q879654321

R12************P987654321
R33************P987654321
R44************P987654321
R45************P987654321
R66************P987654321
R68************P987654321
R77************P987654321
R87************P987654321
R96************P987654321

[ICLA]

VBA 應該一下下就好了，如果您去做一件善事，我就幫您寫一段。

[leonchou]

唔... 再貼一次好了, 希望大家一起討論更好的寫法

Sub gg()
Dim ary() As String
r = 1: re = 1: b = Cells(r, 2)
[E1].CurrentRegion.ClearContents
While b <> ""
　If Cells(r, 1) <> "" Then a = Cells(r, 1)
　ary = Split(b, ",")
　For Each s In ary
　　If s <> "" Then _
　　　Cells(re, 5) = s: Cells(re, 6) = a: re = re + 1
　Next
　r = r + 1
　b = Cells(r, 2)
Wend
[E1].CurrentRegion.Copy [G1]
[G:H].Sort [G1], Header:=xlNo
Set g = Cells(2, 7)
While g <> ""
　If Left(g, 1) <> Left(g.Offset(-1, 0), 1) Then
　　g.Resize(, 2).Insert xlShiftDown
　　Set g = g.Offset(2, 0)
　Else: Set g = g.Offset(1, 0)
　End If
Wend
End Sub

註：Excel97(含)以下版本不支援 Split 函數。

[leonchou]

順便示範如何貼表格 (本區有開放HTML代碼)

	欄A	欄B
列1	A123456789	C123,C456,C789,C741,
列2	Q879654321	B123,B963,B999,B963,
列3		B785,B852,B147,
列4	P987654321	R12,R33,R77,R45,R96,
列5		R68,R44,R66,R87,
列6	P852741963	C987,C456,C841,C123,

[lys338]

感謝版上各位先進的解答
使用上述巨集的確可以做出所需結果
.....假如資料中存在空白欄位,便停止程式執行因而中斷
該如何讓他繼續執行
欄A 欄B
列2 Q879654321 B123,B963,B999,B963,
列3
列4 P987654321 R12,R33,R77,R45,R96,
列5 R68,R44,R66,R87,

感謝指點

PS..檔案已經上傳

[lys338]

感謝版上各位先進的解答
使用上述巨集的確可以做出所需結果
.....假如資料中存在空白欄位,便停止程式執行因而中斷
該如何讓他繼續執行
欄A 欄B
列2 Q879654321 B123,B963,B999,B963,
列3
列4 P987654321 R12,R33,R77,R45,R96,
列5 R68,R44,R66,R87,

感謝指點

PS..檔案已經上傳

[leonchou]

把這一段：
r = 1: re = 1: b = Cells(r, 2)
[E1].CurrentRegion.ClearContents
While b <> ""
　If Cells(r, 1) <> "" Then a = Cells(r, 1)
　ary = Split(b, ",")
　For Each s In ary
　　If s <> "" Then _
　　　Cells(re, 5) = s: Cells(re, 6) = a: re = re + 1
　Next
　r = r + 1
　b = Cells(r, 2)
Wend

改為：
re = 1
[E1].CurrentRegion.ClearContents
For r = 1 To [A65536].End(xlUp).Row
　b = Cells(r, 2)
　If b <> "" Then
　　ary = Split(b, ",")
　　If Cells(r, 1) <> "" Then a = Cells(r, 1)
　　For Each s In ary
　　　If s <> "" Then _
　　　　Cells(re, 5) = s: Cells(re, 6) = a: re = re + 1
　　Next
　End If
Next r

[cinta3344]

看LEON兄的貼每次都會有收穫
像[A65536].End(xlUp).Row這個用法
我就可以來檢驗公司的某些EXCEL檔虛胖的原因了