如何将包含多个值（逗号分隔）的单元格拆分为单独的行？

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

- Morpheus

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

- trincot

---

谢谢，你的回答非常有用！ - Morpheus

Answer 2

我会使用用户定义对象（类）和字典来收集和重新组织数据。使用易于理解的名称，以便未来的维护和调试变得更加容易。

此外，通过使用VBA数组，宏应该比使用多次读写工作表执行得更快。

然后将数据重新编译成所需格式。

我定义了两个类：

1. 网站（我假设每个网站只有一个主要联系人，但如果需要可以轻松更改），包括以下信息：

- 网站名称 - 网站主要联系人 - 公司联系人信息的字典

2. 公司联系人，包括以下信息：

- 姓名 - 关系长度 - 关系强度

我检查确保最后三列中有相同数量的条目。

正如您所看到的，如果需要，向任一类添加其他信息都相当简单。

请键入两个“类模块”和一个“常规模块”，按照注释中指示的重命名“类模块”。

请务必设置对“Microsoft Scripting Runtime”的引用，以便能够使用字典对象。

此外，您可能需要重新定义源/结果工作表/范围的wsSrc、wsRes和rRes。 我将它们放在同一个工作表上以方便使用，但没有必要。

第一个类模块：

Option Explicit
'Rename this to: cSite
'Assuming only a single Site Key Contact per site

Private pSite As String
Private pSiteKeyContact As String
Private pCompanyContactInfo As Dictionary
Private pCC As cCompanyContact

Public Property Get Site() As String
    Site = pSite
End Property
Public Property Let Site(Value As String)
    pSite = Value
End Property

Public Property Get SiteKeyContact() As String
    SiteKeyContact = pSiteKeyContact
End Property
Public Property Let SiteKeyContact(Value As String)
    pSiteKeyContact = Value
End Property

Public Property Get CompanyContactInfo() As Dictionary
    Set CompanyContactInfo = pCompanyContactInfo
End Property

Public Function AddCompanyContactInfo(ByVal CompanyContact As String, _
    ByVal RelationshipLength As String, ByVal RelationshipStrength As String)
    Set pCC = New cCompanyContact
    With pCC
        .CompanyContact = CompanyContact
        .LengthOfRelationship = RelationshipLength
        .StrengthOfRelationship = RelationshipStrength
        pCompanyContactInfo.Add Key:=.CompanyContact, Item:=pCC
    End With
End Function

Private Sub Class_Initialize()
    Set pCompanyContactInfo = New Dictionary
End Sub

类模块 2

Option Explicit
'Rename to: cCompanyContact
Private pCompanyContact As String
Private pLengthOfRelationship As String
Private pStrengthOfRelationship As String

Public Property Get CompanyContact() As String
    CompanyContact = pCompanyContact
End Property
Public Property Let CompanyContact(Value As String)
    pCompanyContact = Value
End Property

Public Property Get LengthOfRelationship() As String
    LengthOfRelationship = pLengthOfRelationship
End Property
Public Property Let LengthOfRelationship(Value As String)
    pLengthOfRelationship = Value
End Property

Public Property Get StrengthOfRelationship() As String
    StrengthOfRelationship = pStrengthOfRelationship
End Property
Public Property Let StrengthOfRelationship(Value As String)
    pStrengthOfRelationship = Value
End Property

常规模块

Option Explicit
'Set Reference to Microsoft Scripting Runtime

Sub SiteInfo()
    Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range
    Dim vSrc As Variant, vRes As Variant
    Dim cS As cSite, dS As Dictionary
    Dim I As Long, J As Long
    Dim V As Variant, W As Variant, X As Variant

'Set source and results worksheets and results range
Set wsSrc = Worksheets("Sheet4")
Set wsRes = Worksheets("Sheet4")
    Set rRes = wsRes.Cells(1, 10)

'Get source data
With wsSrc
    vSrc = .Range(.Cells(1, 1), .Cells(.Rows.Count, 5).End(xlUp))
End With

'Split and collect the data into objects
Set dS = New Dictionary
For I = 2 To UBound(vSrc, 1) 'skip first row
    Set cS = New cSite
        V = Split(vSrc(I, 3), ",")
        W = Split(vSrc(I, 4), ",")
        X = Split(vSrc(I, 5), ",")

        If Not UBound(V) = UBound(W) And UBound(V) = UBound(X) Then
            MsgBox "Mismatch in Company Contact / Length / Strength"
            Exit Sub
        End If

    With cS
        .Site = vSrc(I, 1)
        .SiteKeyContact = vSrc(I, 2)
        For J = 0 To UBound(V)

        If Not dS.Exists(.Site) Then
            .AddCompanyContactInfo Trim(V(J)), Trim(W(J)), Trim(X(J))
            dS.Add .Site, cS
        Else
            dS(.Site).AddCompanyContactInfo Trim(V(J)), Trim(W(J)), Trim(X(J))
        End If

        Next J
    End With
Next I

'Set up Results array
I = 0
For Each V In dS
    I = I + dS(V).CompanyContactInfo.Count
Next V

ReDim vRes(0 To I, 1 To 5)

'Headers
    For J = 1 To UBound(vRes, 2)
        vRes(0, J) = vSrc(1, J)
    Next J

'Populate the data
I = 0
For Each V In dS
    For Each W In dS(V).CompanyContactInfo
        I = I + 1
        vRes(I, 1) = dS(V).Site
        vRes(I, 2) = dS(V).SiteKeyContact
        vRes(I, 3) = dS(V).CompanyContactInfo(W).CompanyContact
        vRes(I, 4) = dS(V).CompanyContactInfo(W).LengthOfRelationship
        vRes(I, 5) = dS(V).CompanyContactInfo(W).StrengthOfRelationship
    Next W
Next V

'Write the results
Set rRes = rRes.Resize(UBound(vRes, 1) + 1, UBound(vRes, 2))
With rRes
    .EntireColumn.Clear
    .Value = vRes
    With .Rows(1)
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
    End With
    .EntireColumn.AutoFit
End With

End Sub

- Ron Rosenfeld

---

非常感谢您的帮助！ - Morpheus