Question

怎样用excel中的宏定时自动发邮件

Answer 1

/步骤

1
创建名字货清单Excel表单先制作货记录表格
您按需要自行制作做行条目
内容加行用于选择否需要自发送邮件

2
再增加名字"清单"Excel表单用于列举各项用重复内容
例列举货址清单联系联系式清单料号清单

各清单定义范围PNlist 命名定义举例各位按需定义
料号清单范围定义 =清单!$G$2:OFFSET(清单!$G$1,COUNTA(清单!$G:$G)-1,0)

COUNTA(清单!$G:$G) 用于计算G列少行内容即少P/N清单 例计算结4
OFFSET($G$1,4-10）计算结即$G$4.

所PNlist 功定义=清单!$G$2:$G$4

定义址清单：Addresslist =清单!$A$2:offset($A$1,counta($A:$A)-1,1)
定义联系清单：Namelist =清单!$D$2:OFFSET(清单!$D$1,COUNTA(清单!$D:$D)-1,1)

通定义清单校验数据 保证误输入通选择提高效率

新建名模板Excel表单定义要通邮件发送内容模板
续通宏拷贝模板填充内容调用outlook发送

注意 模板请放第行第行用与拷贝发送内容做转制

按图片步骤录制名"shipment"宏
宏录制录制单条操作内容操作内容根据自需要按步骤录制
条循环操作需稍微加几句代码
步骤介绍

代码供参考：
Sub shipment()' shipment arrangement

'录制内容
Sheets("货记录").Select
Range("B3:I3").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("邮件模板").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Range("G3:H12").Select
Application.CutCopyMode = False
Selection.Copy
Range("A3").Select
Selection.Insert Shift:=xlDown
Range("B3").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "=R[-2]C[-1]"
Range("B4").Select
ActiveCell.FormulaR1C1 = "=R[-3]C[1]"
Range("B5").Select
ActiveCell.FormulaR1C1 = "=R[-4]C[2]"
Range("B6").Select
ActiveCell.FormulaR1C1 = "=R[-5]C"
Range("B7").Select
ActiveCell.FormulaR1C1 = "=R[-6]C[4]"
Range("B8").Select
ActiveCell.FormulaR1C1 = "=R[-7]C[5]"
Range("B9").Select
ActiveCell.FormulaR1C1 = "=R[-8]C[3]"
Range("B10").Select
ActiveCell.FormulaR1C1 = "=R[-9]C[6]"
Range("B3:B10").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Range("A1:H1").Select
Application.CutCopyMode = False
Selection.ClearContents
Sheets("货记录").Select
Range("J3").Select
ActiveCell.FormulaR1C1 = "Closed"
Range("A3:J3").Select
Range("J3").Activate
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = -0.149998474074526
.PatternTintAndShade = 0
End With
'录制内容
End Sub

打录制宏添加循环代码
按图片步骤及语句录制范围前添加循环代码
Dim i As Integer
Dim j As Integer
Dim g As Integer
Application.ScreenUpdating = False
Sheets("货记录").Select
i = 1
j = Application.WorksheetFunction.CountA(Range("A:A")) + 1
g = 0
'变量i 用于循环变量j用于判断少行需要循环变量g 用于邮件发送定义少行需要发送
For i = 1 To j
If Range("j" & i).Value = "Y" Then
'录制内容
-------------
'录制内容
g = g + 1
Else
End If
Next i

录制范围部代码需按图片更新变量

再添加邮件发送代码其定义名 RangetoHTML（）函数

' 语段用于发送邮件
Sheets("货记录").Select
If g = "0" Then
MsgBox "No new shippment set to Y "
Else
g = 10 * g + 2
Dim OutApp As Object
Dim OutMail As Object
Dim MailBody As Range
Sheets("邮件模板").Select
Set MailBody = Range("A3:B" & g)
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(olMailItem)
On Error Resume Next
With OutMail
.to = "Mama@aimama.com"
.CC = ""
.BCC = ""
.Subject = "Shipment Arrangement"
.BodyFormat = Outlook.OlBodyFormat.olFormatHTML
.HTMLBody = RangetoHTML(MailBody)
.Display
End With
On Error GoTo 0
End If
Sheets("货记录").Select
Application.ScreenUpdating = True

RangetoHTML（）函数 代码申明
代码拷贝粘帖End Sub()

Public Function RangetoHTML(rng As Range)
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook

TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.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
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

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

代码完 需创建按钮便调用宏即

增加条目应行内邮件通知列改"Y",点发送邮件按钮即弹邮件并货通知表单内更改状态