Excel VBA - 逗號分隔單元格到行

Question

請幫助我一些關於下面的excel的建議。在早期的形式是這樣的：

A B C 
1 A1 ;100;200;300;400;500; 
2 A2 ;716;721;428;1162;2183;433;434;1242;717;718; 
3 A3 ;100;101; 

，我想達到這樣的結果：

A B  C 
1 A1 100 
1   200 
1  300 
1  400 
1  500 
2 A2 716 
2  721 
2  428 
2  1162 
2  2183 
2  433 
2  434 
2  1242 
2  717 
2  718 
3 A3 100 
3  101 

我使用此代碼嘗試，但它不返回預期的結果。

Sub SliceNDice() 
Dim objRegex As Object 
Dim X 
Dim Y 
Dim lngRow As Long 
Dim lngCnt As Long 
Dim tempArr() As String 
Dim strArr 
Set objRegex = CreateObject("vbscript.regexp") 
objRegex.Pattern = "^\s+(.+?)$" 
'Define the range to be analysed 
X = Range([a1], Cells(Rows.Count, "b").End(xlUp)).Value2 
ReDim Y(1 To 2, 1 To 1000) 
For lngRow = 1 To UBound(X, 1) 
    'Split each string by ";" 
    tempArr = Split(X(lngRow, 2), ";") 
    For Each strArr In tempArr 
     lngCnt = lngCnt + 1 
     'Add another 1000 records to resorted array every 1000 records 
     If lngCnt Mod 1000 = 0 Then ReDim Preserve Y(1 To 2, 1 To lngCnt + 1000) 
     Y(1, lngCnt) = X(lngRow, 1) 
     Y(2, lngCnt) = objRegex.Replace(strArr, "$1") 
    Next 
Next lngRow 
'Dump the re-ordered range to columns C:D 
[c1].Resize(lngCnt, 2).Value2 = Application.Transpose(Y) 
End Sub 

在此先感謝！

Answer 1

這段代碼爲你工作

Sub SplitAndCopy() 
    Dim sh As Worksheet 
    Set sh = ThisWorkbook.Worksheets("YourTargetSheet") 
    Dim i As Long, j As Long, k As Long 
    k = 2 
    For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row 
     For j = LBound(Split(Range("C" & i).Value, ";")) + 1 To UBound(Split(Range("C" & i).Value, ";")) - 1 
      sh.Range("A" & k).Value = Range("A" & i).Value 
      If j = LBound(Split(Range("C" & i).Value, ";")) + 1 Then 
       sh.Range("B" & k).Value = Range("B" & i).Value 
      End If 
      sh.Range("C" & k).Value = Split(Range("C" & i).Value, ";")(j) 
      k = k + 1 
     Next j 
    Next i 
End Sub 

Answer 2

試試這個：

Option Explicit 

Sub DoSomething() 
Dim i As Integer, j As Integer, k As Integer 
Dim srcwsh As Worksheet, dstwsh As Worksheet 
Dim sTmp As String, sNumbers() As String 

Set srcwsh = ThisWorkbook.Worksheets("Sheet1") 
Set dstwsh = ThisWorkbook.Worksheets("Sheet2") 

i = 1 
j = 1 
Do While srcwsh.Range("A" & i) <> "" 
    sTmp = srcwsh.Range("C" & i) 
    sNumbers = GetNumbers(sTmp) 
    For k = LBound(sNumbers()) To UBound(sNumbers()) 
     dstwsh.Range("A" & j) = srcwsh.Range("A" & i) 
     dstwsh.Range("B" & j) = srcwsh.Range("B" & i) 
     dstwsh.Range("C" & j) = sNumbers(k) 
     j = j + 1 
    Next 
    i = i + 1 
Loop 

Set srcwsh = Nothing 
Set dstwsh = Nothing 


End Sub 

Function GetNumbers(ByVal sNumbers As String) As String() 
Dim sTmp As String 

sTmp = sNumbers 
'remove first ; 
sTmp = Left(sTmp, Len(sTmp) - 1) 
'remove last ;) 
sTmp = Right(sTmp, Len(sTmp) - 1) 

GetNumbers = Split(sTmp, ";") 

End Function 

注：我建議你添加錯誤處理程序。欲瞭解更多信息，請訪問：Exception and Error Handling in Visual Basic

Answer 3

我寧願走這條路：

Private Type data 
    col1 As Integer 
    col2 As String 
    col3 As String 
End Type 

Sub SplitAndCopy() 

    Dim x%, y%, c% 
    Dim arrData() As data 
    Dim splitCol() As String 

    ReDim arrData(1 To Cells(1, 1).End(xlDown)) 

    x = 1: y = 1: c = 1 

    Do Until Cells(x, 1) = "" 
     arrData(x).col1 = Cells(x, 1) 
     arrData(x).col2 = Cells(x, 2) 
     arrData(x).col3 = Cells(x, 3) 

     x = x + 1 
    Loop 

    [a:d].Clear 

    For x = 1 To UBound(arrData) 

     Cells(c, 2) = arrData(x).col2 
     splitCol = Split(Mid(arrData(x).col3, 2, Len(arrData(x).col3) - 2), ";") 

     ' sort splitCol 

     For y = 0 To UBound(splitCol) 
      Cells(c, 1) = arrData(x).col1 
      Cells(c, 3) = splitCol(y) 
      c = c + 1 
     Next y 

    Next x 

End Sub 

我不能完全確定，如果你需要你的第三列進行排序，如果你可以添加排序功能。