Question

我在一列中用逗号分隔值，我需要将它们拆分成新行并保持所有其他数据相同。我的行数可变。

我不知道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

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

Image shown here.

单元格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)&""

填写。

错误：

数字将转换为文字。当然，您可以删除公式末尾的＆amp;“”，但空白单元格将填充0。

Answer 2

给出@ A.S.H。的出色简短回答，下面的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-Enter而不是逗号分隔，则调用看起来像这样：

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”。

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

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

3 个答案: