CODEWITHSUNDEEP
excelemailmergeaggregate
JimboSlice
JimboSlice

Reputation: 3

Condense list by a particular column for use with mail merge

I have a particularly involved problem I'm looking to tackle, but I'll try and keep it concise:

End goal: use Mail Merge to create a giant stack of letters customized to each particular recipient.

Data set I was given:

Company    e-mail                   Part Num    Part Descr.
broncos    [email protected]         6S          iphone 6s plus
broncos    [email protected]    5S          iphone 5s
saints     [email protected]            6           iphone 6
broncos    [email protected]         6S+         iphone 6s plus
packers    [email protected]          6           iphone 6
falcons    [email protected]       5C          iphone 5C
saints     [email protected]            6+          iphone 6 plus
dolphins   [email protected]          5S          iphone 5S
jets       [email protected]             5           iphone 5
jets       [email protected]             5           iphone 5

Now, the tricky part is I'd like to create a letter (Again, via mail merge) on a per e-mail address basis...so I THINK what I need to change this data set in to is:

Company    e-mail                   Part Num 1  Part Descr. 1    Part Num 2 Part Descr. 2
broncos    [email protected]         6S          iphone 6s plus   6S+        iphone 6s plus
broncos    [email protected]    5S          iphone 5s
saints     [email protected]            6           iphone 6         6+         iphone 6 plus
packers    [email protected]          6           iphone 6
falcons    [email protected]       5C          iphone 5C
dolphins   [email protected]          5S          iphone 5S
jets       [email protected]             5           iphone 5

The problems I keep running in to when considering solutions are:

  1. Number of unique Part Nums per e-mail is not constant
  2. I don't want to have repeats (as in the last line item in the above example)

Now that I've written it out it seems like a simple enough problem, but for the life of me I can't think of a viable solution. Should I be looking in to scripting (not something I've worked with yet)?

Once I figure this part out I'll be trying to learn how to use mail merge to create tables of variable length, but that's a topic for another day/post.

Many thanks for your thoughts!

Upvotes: 0

Views: 42

Answers (1)

Ron Rosenfeld
Ron Rosenfeld

Reputation: 60324

Here is one way to do this using Classes and Collections. I assume the source data is on Sheet1 starting in cell A1; and the results go onto sheet2, also starting in cell A1. (It should be readily apparent in the code where to change this).

Duplicates will be ignored. Post back with any questions. A collection has the feature that it returns a 457 error if you try to add an item with an already existing key. We make use of that.

Enter the code as outlined below, in the appropriate modules.

Rename the Class Module: cParts

Class Module

Option Explicit
Private pCompany As String
Private pEmail As String
Private pPartNum As String
Private pPartDesc As String
Private pParts As Collection

Private Sub Class_Initialize()
    Set pParts = New Collection
End Sub

Public Property Get Company() As String
    Company = pCompany
End Property
Public Property Let Company(Value As String)
    pCompany = Value
End Property

Public Property Get Email() As String
    Email = pEmail
End Property
Public Property Let Email(Value As String)
    pEmail = Value
End Property

Public Property Get PartNum() As String
    PartNum = pPartNum
End Property
Public Property Let PartNum(Value As String)
    pPartNum = Value
End Property

Public Property Get PartDesc() As String
    PartDesc = pPartDesc
End Property
Public Property Let PartDesc(Value As String)
    pPartDesc = Value
End Property

Public Property Get Parts() As Collection
    Set Parts = pParts
End Property
Public Function ADDParts(Value As Variant)
    On Error Resume Next
        pParts.Add Value, Join(Value, "|")
    On Error GoTo 0
End Function

Regular Module

Option Explicit
Sub CombineParts()
    Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range
    Dim vSrc As Variant, vRes() As Variant
    Dim cP As cParts, colP As Collection
    Dim I As Long, J As Long
    Dim vParts(0 To 1) As Variant
    Dim lPartCols As Long
    Dim sKey As String

'Set source and results worksheets
Set wsSrc = Worksheets("sheet1")
Set wsRes = Worksheets("sheet2")
    Set rRes = wsRes.Cells(1, 1)

'Read source data into array
With wsSrc
    vSrc = .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(columnsize:=4)
End With

'collect the data
Set colP = New Collection
On Error Resume Next
For I = 1 To UBound(vSrc, 1)
    Set cP = New cParts
    With cP
        .Company = vSrc(I, 1)
        .Email = vSrc(I, 2)
        .PartNum = CStr(vSrc(I, 3))
        .PartDesc = CStr(vSrc(I, 4))
            vParts(0) = .PartNum
            vParts(1) = .PartDesc
        .ADDParts (vParts)
        sKey = .Company & "|" & .Email
        colP.Add cP, sKey
        Select Case Err.Number
            Case 457
                Err.Clear
                colP(sKey).ADDParts (vParts)
            Case Is <> 0
                MsgBox "Error: " & Err.Number & vbTab & Err.Description
        End Select
    End With
Next I
On Error GoTo 0

'How many part columns?
For I = 1 To colP.Count
    J = colP(I).Parts.Count
    lPartCols = IIf(lPartCols > J, lPartCols, J)
Next I
lPartCols = lPartCols * 2

'Set up Results Array
ReDim vRes(0 To colP.Count, 1 To lPartCols + 2)

'Header rows
vRes(0, 1) = "Company"
vRes(0, 2) = "e-mail"
For J = 1 To lPartCols / 2
    vRes(0, (J - 1) * 2 + 3) = "Part Num " & J
    vRes(0, (J - 1) * 2 + 4) = "Part Desc. " & J
Next J

'Populate results array
For I = 1 To colP.Count
    With colP(I)
        vRes(I, 1) = .Company
        vRes(I, 2) = .Email
        For J = 1 To .Parts.Count
            vRes(I, (J - 1) * 2 + 3) = .Parts(J)(0)
            vRes(I, (J - 1) * 2 + 4) = .Parts(J)(1)
        Next J
    End With
Next I

'Write to worksheet
Set rRes = rRes.Resize(rowsize:=UBound(vRes, 1) + 1, columnsize:=UBound(vRes, 2))
With rRes
    .EntireColumn.Clear
    .Value = vRes
    .NumberFormat = "@"
    With .Rows(1)
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
    End With
    .EntireColumn.AutoFit
End With

End Sub

Upvotes: 1

Related Questions