Excel宏-split逗號分隔條目，以新行

Question

目前，我有這個數據在片

Col A Col B Col C 
1  A  angry birds, gaming 
2  B  nirvana,rock,band 

我想要做的第三列是分裂逗號分隔條目，並在類似下面的新行插入什麼：

Col A Col B Col C 
1  A  angry birds 
1  A  gaming 
2  B  nirvana 
2  B  rock 
2  B  band 

我相信這可以用VBA完成，但無法自己弄清楚。

Answer 1

使用變體Scripting.Dictionary

Sub ttt() 
    Dim dic As Object: Set dic = CreateObject("Scripting.Dictionary") 
    Dim x&, cl As Range, rng As Range, k, s 
    Set rng = Range([C1], Cells(Rows.Count, "C").End(xlUp)) 
    x = 1 'used as a key for dictionary and as row number for output 
    For Each cl In rng 
     For Each s In Split(cl.Value2, ",") 
      dic.Add x, Cells(cl.Row, "A").Value2 & "|" & _ 
         Cells(cl.Row, "B").Value2 & "|" & LTrim(s) 
      x = x + 1 
    Next s, cl 
    For Each k In dic 
     Range(Cells(k, "A"), Cells(k, "C")).Value2 = Split(dic(k), "|") 
    Next k 
End Sub 

源：

結果：

Answer 2

這是我對兩列數據的答案。但我想做三欄，有人可以幫我嗎？

你最好使用變體數組而不是單元循環 - 一旦數據集有意義，它們的代碼更加快速。即使你的代碼更長:)

下面的示例轉儲到C和D列，以便您可以看到原始數據。改變[C1] .Resize（lngCnt，2）.Value2 = Application.Transpose（Y），以[A1] .Resize（lngCnt，2）.Value2 = Application.Transpose（Y）轉儲在你的原始數據

[用regexp更新以刪除任何空白後，即「，band」變爲「band」] 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 '將重新排序的範圍轉儲到列C：D [c1] .Resize（lngCnt，2）.Value2 = Application .Transpose（Y） End Sub

Answer 3

這不是一個很好的解決方案，但我需要花一些時間與妻子在一起。

但還有另一種思考方式。

此代碼假定片材被稱爲Sheet4和需要被分割爲COL C.

範圍

Dim lastrow As Integer 
Dim i As Integer 
Dim descriptions() As String 

With Worksheets("Sheet4") 
    lastrow = .Range("C1").End(xlDown).Row 
    For i = lastrow To 2 Step -1 
     If InStr(1, .Range("C" & i).Value, ",") <> 0 Then 
      descriptions = Split(.Range("C" & i).Value, ",") 
     End If 
     For Each Item In descriptions 
      .Range("C" & i).Value = Item 
      .Rows(i).Copy 
      .Rows(i).Insert 
     Next Item 
     .Rows(i).EntireRow.Delete 

    Next i 
End With 

Answer 4

這會做你想做的。

Option Explicit 

Const ANALYSIS_ROW As String = "C" 
Const DATA_START_ROW As Long = 1 

Sub ReplicateData() 
    Dim iRow As Long 
    Dim lastrow As Long 
    Dim ws As Worksheet 
    Dim iSplit() As String 
    Dim iIndex As Long 
    Dim iSize As Long 

    'Application.ScreenUpdating = False 
    Application.Calculation = xlCalculationManual 

    With ThisWorkbook 
     .Worksheets("Sheet1").Copy After:=.Worksheets("Sheet1") 
     Set ws = ActiveSheet 
    End With 

    With ws 
     lastrow = .Cells(.Rows.Count, ANALYSIS_ROW).End(xlUp).Row 
    End With 


    For iRow = lastrow To DATA_START_ROW Step -1 
     iSplit = Split(ws.Cells(iRow, ANALYSIS_ROW).Value2, ",") 
     iSize = UBound(iSplit) - LBound(iSplit) + 1 
     If iSize = 1 Then GoTo Continue 

     ws.Rows(iRow).Copy 
     ws.Rows(iRow).Resize(iSize - 1).Insert 
     For iIndex = LBound(iSplit) To UBound(iSplit) 
      ws.Cells(iRow, ANALYSIS_ROW).Offset(iIndex).Value2 = iSplit(iIndex) 
     Next iIndex 
Continue: 
    Next iRow 

    Application.CutCopyMode = False 
    Application.Calculation = xlCalculationAutomatic 
    'Application.ScreenUpdating = True 
End Sub