vba - 如何将包含多个值(逗号分隔)的单元格拆分为单独的行？

Question

我正在处理一个数据样本，我想根据逗号分隔符将其分成几行。拆分之前我在 Excel 中的数据表如下所示:

我想开发 VBA 代码来拆分 C 列(“公司联系人”)中的值，并为每个“公司联系人”创建单独的行。

到目前为止，我已成功将 C 列中的值拆分为单独的行。但是，我还没有成功拆分 D 列(关系长度)和 E(关系强度)中的值，以便用逗号分隔的每个值对应于 C 列中相应的联系人。

您将在下面找到我借用的用于拆分单元格的代码示例。此代码的限制是它没有拆分表中的其他列，而只是拆分了这一列。

如何使此代码能够拆分其他列中的值？

Sub Splt()
    Dim LR As Long, i As Long
    Dim X As Variant
    Application.ScreenUpdating = False
    LR = Range("A" & Rows.Count).End(xlUp).Row
    Columns("A").Insert
    For i = LR To 1 Step -1
        With Range("B" & i)
            If InStr(.Value, ",") = 0 Then
                .Offset(, -1).Value = .Value
            Else
                X = Split(.Value, ",")
                .Offset(1).Resize(UBound(X)).EntireRow.Insert
                .Offset(, -1).Resize(UBound(X) - LBound(X) + 1).Value = Application.Transpose(X)
            End If
        End With
    Next i
    Columns("B").Delete
    LR = Range("A" & Rows.Count).End(xlUp).Row
    With Range("B1:C" & LR)
        On Error Resume Next
            .SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
         On Error GoTo 0
         .Value = .Value
    End With

    Application.ScreenUpdating = True
End Sub

Answer 1

你不仅应该迭代行，还应该迭代列，并检查每个单元格中是否有这样的逗号。当一行中至少有一个单元格包含逗号时，应将其拆分。

然后，您可以插入该行，并复制新创建的行中逗号之前的部分，同时从原始行中删除该部分，然后将其向上移动一个索引。

每当插入一行时，您还应该注意增加要遍历的行数，否则您将完成不完整的工作。

这是您可以使用的代码:

Sub Splt()
    Dim LR As Long, LC As Long, r As Long, c As Long, pos As Long
    Dim v As Variant

    Application.ScreenUpdating = False
    LR = Cells(Rows.Count, 1).End(xlUp).Row
    LC = Cells(1, Columns.Count).End(xlToLeft).Column
    r = 2
    Do While r <= LR
        For c = 1 To LC
            v = Cells(r, c).Value
            If InStr(v, ",") Then Exit For ' we need to split
        Next
        If c <= LC Then ' We need to split
            Rows(r).EntireRow.Insert
            LR = LR + 1
            For c = 1 To LC
                v = Cells(r + 1, c).Value
                pos = InStr(v, ",")
                If pos Then
                    Cells(r, c).Value = Left(v, pos - 1)
                    Cells(r + 1, c).Value = Trim(Mid(v, pos + 1))
                Else
                    Cells(r, c).Value = v
                End If
            Next
        End If
        r = r + 1
    Loop
    Application.ScreenUpdating = True
End Sub