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

Question

I am working with a sample of data that I'd like to split into several rows based on a comma delimiter. My data table in Excel prior to the split looks like this:

I would like develop VBA code to split values in Column C ('Company Point of Contact') and create separate lines for each 'Company Point of Contact'.

So far I have managed to split the values in Column C into separate lines. However I have not managed to split values in Columns D (Length of Relationship) and E (Strength of Relationship) as well, so that each value separated by a comma corresponds to its respective contact in Column C.

You will find below a sample of the code I borrowed to split my cells. The limitation with this code was that it didn't split the other columns in my table, just the one.

How can I make this code work to split the values in the other columns?

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

You should not only iterate the rows, but also the columns, and check in each cell whether there is such a comma. When at least one of the cells in a row has a comma, it should be split.

You could then insert the row, and copy the parts before the comma in the newly created row, while removing that part from the original row which is then moved up one index.

You should also take care to increase the number of rows to traverse whenever you insert a row, or else you will do an incomplete job.

Here is code you could use:

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

Answer 2

I would adapt an approach using User Defined Objects (Class) and Dictionaries to collect and reorganize the data. Using understandable names so as to make future maintenance and debugging easy.

Also, by using VBA arrays, the macro should execute much more quickly than with multiple reads and writes to/from the worksheet

Then recompile the data into the desired format.

The two classes I have defined as

• Site (and I have assumed that each site has only a single site contact, although that is easily changed, if needed) with information for:

  • Site Name
  • Site Key Contact
  • and a dictionary of Company Contact information

• Company contact, which has the information for

  • name
  • length of relationship
  • Strength of relationship

I do check to make sure there are the same number of entries in the last three columns.

As you can see, it would be fairly simple to add additional information to either Class, if needed.

Enter two Class Modules and one Regular Module Rename the Class Modules as indicated in the comments

Be sure to set a reference to Microsoft Scripting Runtime so as to be able to use the Dictionary object.

Also, you will probably want to redefine wsSrc , wsRes and rRes for your source/results worksheets/ranges. I put them on the same worksheet for convenience, but there is no need to.

Class Module 1

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

Class Module 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

Regular Module

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