Excelmacros – 将逗号分隔的条目分割成新的行

我目前在一张表中有这个数据

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）转储您的原始数据

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使用正则expression式删除任何空白，即“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 '将重新sorting的范围转储到列C：D [c1] .Resize（lngCnt，2）。 Value2 = Application.Transpose（Y）End Sub

Answer 3

这不是一个完美的解决scheme，但我需要花一些时间与妻子。

但还有一种思考的方式。

这段代码假设表单被称为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