一、用户需求
1、表格介绍：
《Item》表为ID、发件人姓名、收件人姓名、邮件标题、邮件内容
《Item》
《NameList》表为ID、姓名、邮箱地址、邮箱签名
《NameList》
《Result》表为序号、发件人邮箱、收件人邮箱、邮件标题、邮件内容
《Result》
2、需求：
将《Item》表中的内容复制到《Result》表中，并将发件人姓名、收件人姓名，邮件内容的[CC]/[To]修改为对应的发件人邮箱地址、收件人邮箱地址、收发人姓名。
二、需求分析
该需求主要是数据匹配方面，但中间的难点为一行多个姓名如何去匹配、邮件内容对应匹配，因此需采用数组和字典来解决该问题，具体步骤如下：
1、设计字典dict，装载《NameList》的Name和Email，用来实现匹配姓名对应的邮箱地址；
2、设计姓名替换email的方法，具体逻辑如下：
数组arr装载《Item》表；使用split方法将To和CC的多人切换为单人数组使用字典进行匹配3、设计邮件内容自动更换方法，使用Replace方法替换关键字
代码实现
Sub OutputResult()' 输出结果Worksheets("Result").ActivateActiveSheet.UsedRange.Offset(1).ClearContentsDim arr, arr2, arr3, arr4(), dict As ObjectWorksheets("NameList").Activatearr2 = Range("b2:c" & [c9999].End(xlUp).Row)Set dict = email(arr2)Worksheets("Items").Activatearr3 = Range(Cells(2, 1), Cells([e3000].End(xlUp).Row, 5))For i = 1 To UBound(arr3, 1)arr3(i, 5) = ReplaceContent(arr3(i, 5), arr3(i, 2), arr3(i, 3))arr3(i, 1) = iarr3(i, 2) = ReplaceEmail(arr3(i, 2), dict)arr3(i, 3) = ReplaceEmail(arr3(i, 3), dict)Next iWorksheets("Result").Activate[a2].Resize(UBound(arr3)) = WorksheetFunction.Index(arr3, 0, 1)[B2].Resize(UBound(arr3)) = WorksheetFunction.Index(arr3, 0, 2)[C2].Resize(UBound(arr3)) = WorksheetFunction.Index(arr3, 0, 3)[E2].Resize(UBound(arr3)) = WorksheetFunction.Index(arr3, 0, 5)End SubFunction email(arr)' 生成邮件字典' arr：类型,数组Dim dict As ObjectSet dict = CreateObject("scripting.dictionary")For i = 1 To UBound(arr)dict(arr(i, 1)) = arr(i, 2)Next iSet email = dictEnd FunctionFunction ReplaceContent(s, em, cc)' 自动替换收发人的姓名If instr(s, "[To]") > 0 Thens = Replace(s, "[To]", em)Elses = Replace(s, "[CC]", cc)End IfReplaceContent = sEnd FunctionFunction ReplaceEmail(s, dict As Object)' 将姓名替换为emailDim arr, i%, s1 As Stringarr = Split(s, ";")If UBound(arr) = -1 Thens1 = ""ElseIf UBound(arr) = 0 Thens1 = dict.Item(s)ElseFor i = 0 To UBound(arr)If i = 0 Thens1 = dict.Item(arr(i))Elses1 = s1 & ";" & dict.Item(arr(i))End IfNext iEnd IfReplaceEmail = s1End Function
