試問以下問題(*表示區隔,沒有意義,不然兩欄的數字會連在一起)
*********欄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

贊助商連結

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

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

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 函數。

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

<table border=1 style="font-size:15px;line-height:15px;"><tr><td width=30>&nbsp;<td>欄A<td>欄B
<tr><td>列1<td style="background:#F0FFFF;">A123456789<td style="background:#F0FFFF;">C123,C456,C789,C741,
<tr><td>列2<td style="background:#F0FFFF;">Q879654321<td style="background:#F0FFFF;">B123,B963,B999,B963,
<tr><td>列3<td style="background:#F0FFFF;">&nbsp;<td style="background:#F0FFFF;">B785,B852,B147,
<tr><td>列4<td style="background:#F0FFFF;">P987654321<td style="background:#F0FFFF;">R12,R33,R77,R45,R96,
<tr><td>列5<td style="background:#F0FFFF;">&nbsp;<td style="background:#F0FFFF;">R68,R44,R66,R87,
<tr><td>列6<td style="background:#F0FFFF;">P852741963<td style="background:#F0FFFF;">C987,C456,C841,C123,
</table>

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

感謝指點

PS..檔案已經上傳

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

感謝指點

PS..檔案已經上傳

把這一段：
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

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