vba 将单元格值拆分为多行并保留其他数据

Split cell values into multiple rows and keep other data

提问by MJ95

I have values in column B separated by commas. I need to split them into new rows and keep the other data the same.

我在 B 列中有值用逗号分隔。我需要将它们拆分为新行并保持其他数据不变。

I have a variable number of rows.

我有可变数量的行。

I don't know how many values will be in the cells in Column B, so I need to loop over the array dynamically.

我不知道 B 列的单元格中有多少个值，所以我需要动态地循环遍历数组。

Example:

例子：

ColA       ColB       ColC      ColD
Monday     A,B,C      Red       Email

Output:

输出：

ColA       ColB       ColC      ColD
Monday       A         Red       Email
Monday       B         Red       Email
Monday       C         Red       Email

Have tried something like:

尝试过类似的东西：

colArray = Split(ws.Cells(i, 2).Value, ", ")
For i = LBound(colArray) To UBound(colArray)
    Rows.Insert(i)
Next i

回答by A.S.H

Try this, you can easily adjust it to your actual sheet name and column to split.

试试这个，您可以轻松地将其调整为您的实际工作表名称和要拆分的列。

Sub splitByColB()
    Dim r As Range, i As Long, ar
    Set r = Worksheets("Sheet1").Range("B999999").End(xlUp)
    Do While r.row > 1
        ar = Split(r.value, ",")
        If UBound(ar) >= 0 Then r.value = ar(0)
        For i = UBound(ar) To 1 Step -1
            r.EntireRow.Copy
            r.Offset(1).EntireRow.Insert
            r.Offset(1).value = ar(i)
        Next
        Set r = r.Offset(-1)
    Loop
End Sub

回答by Comintern

You can also just do it in place by using a Doloop instead of a Forloop. The only real trick is to just manually update your row counter every time you insert a new row. The "static" columns that get copied are just a simple matter of caching the values and then writing them to the inserted rows:

您也可以通过使用Do循环而不是循环来就地完成For。唯一真正的技巧是每次插入新行时手动更新行计数器。被复制的“静态”列只是缓存值然后将它们写入插入的行的简单问题：

Dim workingRow As Long
workingRow = 2
With ActiveSheet
    Do While Not IsEmpty(.Cells(workingRow, 2).Value)
        Dim values() As String
        values = Split(.Cells(workingRow, 2).Value, ",")
        If UBound(values) > 0 Then
            Dim colA As Variant, colC As Variant, colD As Variant
            colA = .Cells(workingRow, 1).Value
            colC = .Cells(workingRow, 3).Value
            colD = .Cells(workingRow, 4).Value
            For i = LBound(values) To UBound(values)
                If i > 0 Then
                    .Rows(workingRow).Insert xlDown
                End If
                .Cells(workingRow, 1).Value = colA
                .Cells(workingRow, 2).Value = values(i)
                .Cells(workingRow, 3).Value = colC
                .Cells(workingRow, 4).Value = colD
                workingRow = workingRow + 1
            Next
        Else
            workingRow = workingRow + 1
        End If
    Loop
End With

回答by ASH

This will do what you want.

这会做你想做的。

Option Explicit

Const ANALYSIS_ROW As String = "B"
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("Sheet4").Copy After:=.Worksheets("Sheet4")
        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

回答by user3471272

A formula solution is close to your requirement.

配方解决方案接近您的要求。

Cell G1is the delimiter. In this case a comma.

单元格G1是分隔符。在这种情况下，逗号。

Helper E1:=SUM(E1,LEN(B1)-LEN(SUBSTITUTE(B1,$H,"")))+1

You must fill the above formula one row more.

您必须将上述公式再填写一行。

A8:=a1

Fill this formula to the right.

把这个公式填到右边。

A9:=LOOKUP(ROW(1:1),$E:$E,A:A)&""

Fill this formula to the right and then down.

向右填充这个公式，然后向下填充。

B9:=MID($H&LOOKUP(ROW(A1),E:E,B:B)&$H,FIND("ܳ",SUBSTITUTE($H&LOOKUP(ROW(A1),E:E,B:B)&$H,$H,"ܳ",ROW(A2)-LOOKUP(ROW(A1),E:E)))+1,FIND("ܳ",SUBSTITUTE($H&LOOKUP(ROW(A1),E:E,B:B)&$H,$H,"ܳ",ROW(A2)-LOOKUP(ROW(A1),E:E)+1))-FIND("ܳ",SUBSTITUTE($H&LOOKUP(ROW(A1),E:E,B:B)&$H,$H,"ܳ",ROW(A2)-LOOKUP(ROW(A1),E:E)))-1)&""

Fill down.

填下来。

Bug:

漏洞：

Numbers will be converted to Text. Of course you can remove the &"" at the end of the formula, but blank cells will be filled with 0.

数字将转换为文本。当然你可以去掉公式末尾的&""，但是空白单元格会用0填充。

回答by Noah Bridge

Given @A.S.H.'s excellent and brief answer, the VBA function below might be a bit of an overkill, but it will hopefully be of some help to someone looking for a more "generic" solution. This method makes sure not to modify the cells to the left, to the right, or above the table of data, in case the table does not start in A1 or in case there is other data on the sheet besides the table. It also avoids copying and inserting entire rows, and it allows you to specify a separator other than a comma.

鉴于@ASH 出色而简短的回答，下面的 VBA 函数可能有点矫枉过正，但希望它对寻找更“通用”解决方案的人有所帮助。此方法可确保不要修改数据表左侧、右侧或上方的单元格，以防表不在 A1 中开始，或者工作表上除表外还有其他数据。它还避免了复制和插入整行，并且允许您指定逗号以外的分隔符。

This function happens to have similarities to @ryguy72's procedure, but it does not rely on the clipboard.

这个函数恰好与@ryguy72 的过程有相似之处，但它不依赖于剪贴板。

Function SplitRows(ByRef dataRng As Range, ByVal splitCol As Long, ByVal splitSep As String, _
                   Optional ByVal idCol As Long = 0) As Boolean
  SplitRows = True

  Dim oldUpd As Variant: oldUpd = Application.ScreenUpdating
  Dim oldCal As Variant: oldCal = Application.Calculation

  On Error GoTo err_sub

  'Modify application settings for the sake of speed
  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual

  'Get the current number of data rows
  Dim rowCount As Long: rowCount = dataRng.Rows.Count

  'If an ID column is specified, use it to determine where the table ends by finding the first row
  '  with no data in that column
  If idCol > 0 Then
    With dataRng
      rowCount = .Offset(, idCol - 1).Resize(, 1).End(xlDown).Row - .Row + 1
    End With
  End If

  Dim splitArr() As String
  Dim splitLb As Long, splitUb As Long, splitI As Long
  Dim editedRowRng As Range

  'Loop through the data rows to split them as needed
  Dim r As Long: r = 0
  Do While r < rowCount
    r = r + 1

    'Split the string in the specified column
    splitArr = Split(dataRng.Cells(r, splitCol).Value & "", splitSep)
    splitLb = LBound(splitArr)
    splitUb = UBound(splitArr)

    'If the string was not split into more than 1 item, skip this row
    If splitUb <= splitLb Then GoTo splitRows_Continue

    'Replace the unsplit string with the first item from the split
    Set editedRowRng = dataRng.Resize(1).Offset(r - 1)
    editedRowRng.Cells(1, splitCol).Value = splitArr(splitLb)

    'Create the new rows
    For splitI = splitLb + 1 To splitUb
      editedRowRng.Offset(1).Insert 'Add a new blank row
      Set editedRowRng = editedRowRng.Offset(1) 'Move down to the next row
      editedRowRng.Offset(-1).Copy Destination:=editedRowRng 'Copy the preceding row to the new row
      editedRowRng.Cells(1, splitCol).Value = splitArr(splitI) 'Place the next item from the split string

      'Account for the new row in the counters
      r = r + 1
      rowCount = rowCount + 1
    Next

splitRows_Continue:
  Loop

exit_sub:
  On Error Resume Next

  'Resize the original data range to reflect the new, full data range
  If rowCount <> dataRng.Rows.Count Then Set dataRng = dataRng.Resize(rowCount)

  'Restore the application settings
  If Application.ScreenUpdating <> oldUpd Then Application.ScreenUpdating = oldUpd
  If Application.Calculation <> oldCal Then Application.Calculation = oldCal
  Exit Function

err_sub:
  SplitRows = False
  Resume exit_sub
End Function

---

---

Function input and output

功能输入输出

To use the above function, you would specify

要使用上述功能，您需要指定

• the range containing the rows of data (excluding the header)
• the (relative) number of the column within the range with the string to split
• the separator in the string to split
• the optional (relative) number of the "ID" column within the range (if a number >=1 is provided, the first row with no data in this column will be taken as the last row of data)

• 包含数据行的范围（不包括标题）
• 要拆分的字符串范围内列的（相对）编号
• 要拆分的字符串中的分隔符
• 范围内“ID”列的可选（相对）编号（如果提供的数字>=1，则该列中没有数据的第一行将作为最后一行数据）

The range object passed in the first argument will be modified by the function to reflect the range of all the new data rows (including all inserted rows). The function returns True if no errors were encountered, and False otherwise.

第一个参数中传递的范围对象将被函数修改以反映所有新数据行（包括所有插入的行）的范围。如果没有遇到错误，该函数返回 True，否则返回 False。

---

---

Examples

例子

For the range illustrated in the original question, the call would look like this:

对于原始问题中说明的范围，调用将如下所示：

SplitRows Range("A2:C2"), 2, "," 

If the same table started in F5 instead of A1, and if the data in column G (i.e. the data that would fall in column B if the table started in A1) was separated by Alt-Enters instead of commas, the call would look like this:

如果同一个表格以 F5 而不是 A1 开头，并且如果 G 列中的数据（即如果表格以 A1 开头，将落入 B 列中的数据）由 Alt-Enters 而不是逗号分隔，则调用将如下所示这个：

SplitRows Range("F6:H6"), 2, vbLf 

If the table contained the row header plus 10 rows of data (instead of 1), and if it started in F5 again, the call would look like this:

如果表包含行标题和 10 行数据（而不是 1 行），并且再次以 F5 开始，则调用将如下所示：

SplitRows Range("F6:H15"), 2, vbLf 

If there was no certainty about the number of rows, but we knew that all the valid rows are contiguous and always have a value in column H (i.e. the 3rd column in the range), the call could look something like this:

如果不确定行数，但我们知道所有有效行都是连续的，并且在 H 列（即范围中的第 3 列）中始终有一个值，则调用可能如下所示：

SplitRows Range("F6:H1048576"), 2, vbLf, 3 

In Excel 95 or lower, you would have to change "1048576" to "16384", and in Excel 97-2003, to "65536".

在 Excel 95 或更低版本中，您必须将“1048576”更改为“16384”，在 Excel 97-2003 中更改为“65536”。