Question

我有一个特别涉及的问题，我正在寻求解决，但我会尽量保持简洁：

结束目标：使用邮件合并创建为每个特定收件人定制的大量字母。

给出了数据集：

Company    e-mail                   Part Num    Part Descr.
broncos    jman@hotmail.com         6S          iphone 6s plus
broncos    pey_me@nationwide.com    5S          iphone 5s
saints     drew@NOLA.gov            6           iphone 6
broncos    jman@hotmail.com         6S+         iphone 6s plus
packers    A-A-ron@pac.com          6           iphone 6
falcons    MattyIce@yahoo.com       5C          iphone 5C
saints     drew@NOLA.gov            6+          iphone 6 plus
dolphins   rhill@gmail.net          5S          iphone 5S
jets       Tebow@uf.edu             5           iphone 5
jets       Tebow@uf.edu             5           iphone 5

现在，棘手的部分是我想在每个电子邮件地址的基础上创建一封信（再次，通过邮件合并）...所以我认为我需要什么将此数据集更改为：

Company    e-mail                   Part Num 1  Part Descr. 1    Part Num 2 Part Descr. 2
broncos    jman@hotmail.com         6S          iphone 6s plus   6S+        iphone 6s plus
broncos    pey_me@nationwide.com    5S          iphone 5s
saints     drew@NOLA.gov            6           iphone 6         6+         iphone 6 plus
packers    A-A-ron@pac.com          6           iphone 6
falcons    MattyIce@yahoo.com       5C          iphone 5C
dolphins   rhill@gmail.net          5S          iphone 5S
jets       Tebow@uf.edu             5           iphone 5

我在考虑解决方案时遇到的问题是：

每封电子邮件中唯一的部分名称数不是常数
我不想重复（如上例中的最后一项）

既然我已经把它写出来了，这似乎是一个简单的问题，但对于我的生活，我无法想到一个可行的解决方案。我应该查看脚本（不是我曾经使用过的东西）吗？

一旦我弄清楚这一部分，我将尝试学习如何使用邮件合并来创建可变长度的表格，但这是另一天/帖子的主题。

非常感谢你的想法！

Answer 1

以下是使用类和集合执行此操作的一种方法。我假设源数据在Sheet1上从单元格A1开始;结果进入sheet2，也从单元格A1开始。（在代码中应该很明显地改变这一点）。

将忽略重复项。回复任何问题。如果您尝试添加具有现有密钥的项目，则集合具有返回457错误的功能。我们利用它。

在相应的模块中输入如下所述的代码。

重命名课程模块： cParts

班级单元

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

常规模块

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

通过特定列压缩列表以用于邮件合并

1 个答案:

班级单元

常规模块