用于邮件合并的特定列的浓缩列表

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

最终目标：使用邮件合并为每个特定收件人创build一大堆信件。

数据集我被给了：

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

现在，棘手的部分是我想创build一个字母（再次，通过邮件合并）在每个电子邮件地址的基础上…所以我想我需要改变这个数据集是：

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

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

1. 每个电子邮件的唯一部分数量不是固定的
2. 我不想重复（如上例中的最后一行）

现在我已经写出来了，这似乎是一个足够简单的问题，但对于我的生活，我想不出一个可行的解决scheme。 我应该寻找脚本（不是我曾经工作过的）？

一旦我弄清了这一部分，我将试图学习如何使用邮件合并来创build可变长度的表格，但是这是另一个日子/post的主题。

非常感谢您的想法！

Answer 1

这是使用类和集合来完成的一种方法。 我假设源数据在单元格A1中的Sheet1上; 结果进入sheet2，也从单元格A1开始。 （在代码中，应该很容易明白这一点）。

重复将被忽略。 回发任何问题。 如果您尝试使用已存在的键添加项目，集合具有返回457错误的function。 我们利用这个。

在相应的模块中input下面列出的代码。

重命名类模块： 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