求大神帮忙解决自动生成邮件功能

langshufang · 发表于 2018-8-13 12:15

各位大佬，帮忙看看如下需求能否实现啊，每天数据量很大，要提取满足条件的信息，做邮件触达。

附件sheet1是系统按日导出的累计历史数据，表头恒定不变，以后每天的数据都往后黏贴。数据量每天1万条左右。

需求：

我们手里会有上文提到的累计的多天历史数据原始表，希望达到的效果是，可以通过大佬的鼎力相助：

1. 运用宏自动筛选出近7天都有撞线的广告主ID。（PS：每个广告主PIN汇总近7天均出现撞线情况的计划ID-广告活动）；

2. 按照我们匹配好邮箱的表格直接生成sheet2 中的“表一”“表二”（这两个表为给广告主发的邮件正文的内容）；

3. 根据广告主PIN所对应的邮箱自动发送配有固定文案“xxxx”及对应表格的邮件，正文模板如下。

邮件正文模板：（固定内容与针对不同用户的个性化内容均在下文标出）

标题:提醒您撞线啦！（固定）

尊敬的用户您好：(固定)

Xxxxxxxxxxxxxxxxxxxxxxxxxxxx （固定）

日期	PIN	供应商名称	计划ID	计划名	撞线次数	计划预算	计划消耗	第一次撞线时间
20180730	bd	小花	345	蓝色	1	200.00	210.68	2018/7/30 21:40
20180801	bd	小花	345	蓝色	2	100.00	106.34	2018/8/1 22:20
20180802	bd	小花	345	蓝色	2	100.00	110	2018/8/2 22:40
20180803	bd	小花	345	蓝色	1	100.00	110	2018/8/3 22:00
20180804	bd	小花	345	蓝色	1	100.00	202.86	2018/8/4 21:20
20180805	bd	小花	345	蓝色	1	100.00	107.53	2018/8/5 21:00
20180806	bd	小花	345	蓝色	1	100.00	104.35	2018/8/6 21:40

（每个用户有不一样的对应表格）

苏小亓 · 发表于 2018-8-13 13:13

EXCEL必备工具箱有这个功能，免费的。百度搜索EXCEL必备工具箱第一个就是。

zhenghui13 · 发表于 2018-8-13 14:01

简单写了一下，不过我只会将数据添加入附件，不太清楚怎么样表格复制到邮件正文中.

Const d_Span = 7
Sub TZ()
'---------------Define Workbook------------------------------
Dim Dic As Object, Pin$, key, k
Dim c_Date As Date, b_Date As Date
Dim arr, brr
Dim wb As Workbook
'---------------Define Outlook-------------------------------
Dim wbStr As String, nlist As String
Dim OutlookApp
Dim newMail
Set OutlookApp = CreateObject("Outlook.Application")
'=============================================================
Application.ScreenUpdating = False
arr = Sheet1.UsedRange
c_Date = Date: b_Date = c_Date - d_Span
Set Dic = CreateObject("Scripting.Dictionary")
'获取Pin+Email,用以文件循环
For i = 2 To UBound(arr)
Pin = arr(i, 2)
If Not Dic.Exists(Pin) And Pin <> "" Then Dic(Pin) = arr(i, 22)
Next i
key = Dic.keys
'----------------Process Data----------------------------------
For k = 0 To UBound(key)
Pin = key(k) 'PIN
brr = Get_Data_From_Array(arr, Pin, c_Date, b_Date)
If Not IsArray(brr) Then Exit Sub
Set wb = Workbooks.Add
wb.Sheets(1).[A1].Resize(UBound(brr), UBound(brr, 2)) = brr
wb.SaveAs ThisWorkbook.Path & "" & Pin & ".xlsx"
wbStr = wb.FullName
wb.Close
'---------------run OUTLOOK EMAIL------------------------------
Set newMail = OutlookApp.CreateItem(olMailItem)
With newMail
.Subject = "提醒您撞线啦！"
.Body = "尊敬的用户您好："
Set myAttachments = newMail.Attachments
myAttachments.Add wbStr, olByValue, 1, "workbook"
.to = Dic(Pin)
.Save
End With
Set newMail = Nothing
Next k
Application.ScreenUpdating = True
'-----------------------Release Memory-------------------------------
Set OutlookApp = Nothing
Set Dic = Nothing
End Sub
Function Get_Data_From_Array(arr, ByVal Pin$, c_Date, b_Date)
Dim i, m
Dim Sk$
Dim x_Date As Date
Dim out(1 To 100, 1 To 9)
m = 1: i = 1
'标题
out(m, 1) = arr(i, 1)
out(m, 2) = arr(i, 2)
out(m, 3) = arr(i, 6)
out(m, 4) = arr(i, 9)
out(m, 5) = arr(i, 10)
out(m, 6) = arr(i, 13)
out(m, 7) = arr(i, 11)
out(m, 8) = arr(i, 12)
out(m, 9) = arr(i, 14)
For i = 2 To UBound(arr)
Sk = arr(i, 2) 'PIN
If Sk = Pin Then
x_Date = String_2_Date(arr(i, 1)) 'Date
If x_Date <= c_Date And x_Date >= b_Date Then
m = m + 1
out(m, 1) = arr(i, 1)
out(m, 2) = arr(i, 2)
out(m, 3) = arr(i, 6)
out(m, 4) = arr(i, 9)
out(m, 5) = arr(i, 10)
out(m, 6) = arr(i, 13)
out(m, 7) = arr(i, 11)
out(m, 8) = arr(i, 12)
out(m, 9) = arr(i, 14)
End If
End If
Next i
If m = 1 Then Exit Function
Get_Data_From_Array = out
End Function
Function String_2_Date(ByVal Str$) As Date
a = Format(Str, "####-##-##")
b = CDate(a)
String_2_Date = b
End Function

复制代码

zhenghui13 · 发表于 2018-8-14 09:44

在网上又查找了一下，可以将EXCEL另存为htm格式，然后copy到邮件中。
代码如下，请测试是否可以达到效果。

Const d_Span = 7
Sub AutoEmail_Html()
'---------------Define Workbook------------------------------
Dim Dic As Object, Pin$, key, k
Dim c_Date As Date, b_Date As Date
Dim arr, brr
Dim wb As Workbook
'---------------Define Outlook-------------------------------
Dim wbStr As String, nlist As String
Dim OutlookApp As Outlook.Application
Dim OutlookItem As Outlook.MailItem
Dim newMail
Dim strAdr$
'=============================================================
Application.ScreenUpdating = False
arr = Sheet1.UsedRange
c_Date = #8/6/2018#: b_Date = c_Date - d_Span
Set Dic = CreateObject("Scripting.Dictionary")
'获取名字+Email,用以文件循环
For i = 2 To UBound(arr)
Pin = arr(i, 2)
If Not Dic.Exists(Pin) And Pin <> "" Then Dic(Pin) = arr(i, 22)
Next i
key = Dic.keys
'----------------Process Data----------------------------------
For k = 0 To UBound(key)
Pin = key(k) 'PIN
brr = Get_Data_From_Array(arr, Pin, c_Date, b_Date)
If Not IsArray(brr) Then Exit Sub
'新建工作表，用以Email附件
Set wb = Workbooks.Add
wb.Sheets(1).[A1].Resize(UBound(brr), UBound(brr, 2)) = brr
wb.SaveAs ThisWorkbook.Path & "" & Pin & ".xlsx"
wbStr = wb.FullName
wb.Close
strAdr = ThisWorkbook.Path & "" & Pin
'---------------run OUTLOOK EMAIL------------------------------
Set OutlookApp = New Outlook.Application
Set OutlookItem = OutlookApp.CreateItem(olMailItem)
With OutlookItem
.Subject = "提醒您撞线啦！"
.BodyFormat = Outlook.OlBodyFormat.olFormatHTML '添加表格内容须设为HTML格式
.HTMLBody = RangeToHTML(brr, strAdr) 'Array转为HTML的内容
.Display
Set myAttachments = OutlookItem.Attachments
myAttachments.Add wbStr, olByValue, 1, "workbook"
.to = Dic(Pin)
.Save
End With
Set OutlookItem = Nothing
Next k
Application.ScreenUpdating = True
'-----------------------Release Memory-------------------------------
Set OutlookApp = Nothing
Set Dic = Nothing
End Sub
'关于EXCEL转Html，不可开启R1C1格式，不然会出错
Public Function RangeToHTML(rng, sAddress$)
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
Dim uRng
TempFile = sAddress & ".htm"
' rng.Copy
'新建文件，另存为html
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1, 1).Resize(UBound(rng), UBound(rng, 2)) = rng
.Cells.Columns.AutoFit
' .UsedRange.Copy
' .Cells(1).PasteSpecial Paste:=8
' .Cells(1).PasteSpecial xlPasteValues, , False, False
' .Cells(1).PasteSpecial xlPasteFormats, , False, False
' .Cells(1).Select
' Application.CutCopyMode = False
' On Error Resume Next
' .DrawingObjects.Visible = True
' .DrawingObjects.Delete
' On Error GoTo 0
End With
'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'Read all data from htm file into RangetoHtml
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangeToHTML = ts.ReadAll
ts.Close
RangeToHTML = Replace(RangeToHTML, "align=center x:publishsource=", "align=left x:publishsource=")
TempWB.Close savechanges:=False
'Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
'获取相关数据
Function Get_Data_From_Array(arr, ByVal Pin$, c_Date, b_Date)
Dim i, m
Dim Sk$
Dim x_Date As Date
Dim out(1 To 100, 1 To 9)
m = 1: i = 1
'标题
out(m, 1) = arr(i, 1)
out(m, 2) = arr(i, 2)
out(m, 3) = arr(i, 6)
out(m, 4) = arr(i, 9)
out(m, 5) = arr(i, 10)
out(m, 6) = arr(i, 13)
out(m, 7) = arr(i, 11)
out(m, 8) = arr(i, 12)
out(m, 9) = arr(i, 14)
For i = 2 To UBound(arr)
Sk = arr(i, 2) 'PIN
If Sk = Pin Then
x_Date = String_2_Date(arr(i, 1)) 'Date
If x_Date <= c_Date And x_Date >= b_Date Then
m = m + 1
out(m, 1) = arr(i, 1)
out(m, 2) = arr(i, 2)
out(m, 3) = arr(i, 6)
out(m, 4) = arr(i, 9)
out(m, 5) = arr(i, 10)
out(m, 6) = arr(i, 13)
out(m, 7) = arr(i, 11)
out(m, 8) = arr(i, 12)
out(m, 9) = arr(i, 14)
End If
End If
Next i
If m = 1 Then Exit Function
Get_Data_From_Array = out
End Function
'字符日期转换字日期格式
Function String_2_Date(ByVal Str$) As Date
a = Format(Str, "####-##-##")
b = CDate(a)
String_2_Date = b
End Function

复制代码

langshufang · 发表于 2018-8-16 17:54

zhenghui13 发表于 2018-8-14 09:44
在网上又查找了一下，可以将EXCEL另存为htm格式，然后copy到邮件中。
代码如下，请测试是否可以达到效果。 ...

万分感谢！辛苦！我去测试一下哈~
祝好

小绿草 · 发表于 2018-8-16 18:31

学习了。。。。。。

		自动登录	找回密码
密码			免费注册

[求助] 求大神帮忙解决自动生成邮件功能