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

Question

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

我有可变数量的行。

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

例子：

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

输出：

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

尝试过类似的东西：

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

Answer 1

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

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

Answer 2

您也可以通过使用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

Answer 3

这会做你想做的。

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

Answer 4

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

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

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

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

A8:=a1

把这个公式填到右边。

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

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

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

填下来。

漏洞：

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

Answer 5

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

这个函数恰好与@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

---

功能输入输出

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

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

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

---

例子

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

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

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

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

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

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

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

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

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