<em>Excel</em>的VBA通过outlook<em>发邮件</em&

用条件判断就行了

发邮件核心函数用这个

Sub emailTo(ByVal toEmail As String, Optional ByVal toCC As String, Optional ByVal toBCC As String, Optional ByVal toSubject As String, Optional ByVal toBody As String, Optional ByVal attach As String, Optional ByVal doPaste As Boolean = False) 
'支持群发邮件 （相同主题、正文） _ 
Email地址用:隔开 支持直接使用姓名e799bee5baa6e79fa5e98193e4b893e5b19e337、通讯组列表名 _ 
附件路径用:隔开 
With Application 
'.EnableEvents = False 
'.ScreenUpdating = False 
End With 
Dim myOL As New Outlook.Application, myMail As MailItem, myNamespace As Namespace, myDistList As DistListItem, myFolder As Folder, emailAry(2), ccAry, bccAry, attachAry, tmpStr As String 
Set myOL = New Outlook.Application 
Set myNamespace = myOL.GetNamespace("MAPI") 
Set myFolder = myNamespace.GetDefaultFolder(olFolderContacts) 
'myFolder.display 
emailAry(0) = toEmail 
emailAry(1) = toCC 
emailAry(2) = toBCC 
attachAry = Split(attach, ";") 
Set myMail = myOL.CreateItem(olMailItem) 
With myMail 
.To = toEmail 
.cc = toCC 
.BCC = toBCC 
.Subject = toSubject 
.BodyFormat = olFormatHTML 
.HTMLBody = '批量发送邮件VBA by zzllrr iMacro V1.0' 
'.body = toBody 
If UBound(attachAry) > -1 Then 
For Each att In attachAry 
.Attachments.Add att 
Next att 
End If 
'Application.ActivateMicrosoftApp xlMicrosoftMail 
.display 
'myOL.ActiveExplorer 
'AppActivate myMail 
SendKeys "{TAB}" '从subject切换到正文 
If doPaste Then 
Application.Wait Now + TimeValue("00:00:04") 
SendKeys "{END}" 
SendKeys "^v" 
'SendKeys "~" 
End If 
Application.Wait Now + TimeValue("00:00:02") 
' .Save 
' .Close olSave 
'.send 
End With 
Set myMail = Nothing 
Set myOL = Nothing 
End Sub

语句Sheets("Sheet2").SelectActiveSheet.Range($A$1:$J$6).AutoFilter Field:=3,Criterial1:=_"=In Progress", Operator:=xlOr,Criteria2:="=Resolved"Columns("G:G").Select
修改为
Sheets("Sheet2").SelectActiveSheet.Range($A$1:$J$6).AutoFilter Field:=3,Criterial1:=_"<>closed", Operator:=xlOr,Criteria2:="=Resolved"Columns("G:G").Select
以下代码，数据在抄sheet1的A到D列，表头在第二行百
取前三度个复制到H列

Set conn = CreateObject("adodb.connection")
conn.Open "provider=microsoft.jet.oledb.4.0;extended properties=excel 8.0;data source=" & ThisWorkbook.FullName
Sql = "select top 3 * from [sheet1$A2:D] order by 销量 desc"
[H3].CopyFromRecordset conn.Execute(Sql)
conn.Close: Set conn = Nothing
[A2:D2].Copy [H2]

一、建立亲友通讯录
　e799bee5baa6e4b893e5b19e332　在工作表中建立一个包含不同收件人、主题、内容和附件的亲友通讯录。
二、使用宏实现自动发送电子邮件
　　打开“工具→宏→Visual Basic编辑器”，单击“插入→模块”插入一个模块，在“工程”窗口中双击插入的模块，打开它的代码窗口，并输入以下宏：
　　Sub 全自动发送邮件()
　　"要能正确发送并需要对Microseft Outlook进行有效配置
　　On Error Resume Next
　　Dim rowCount, endRowNo
　　Dim objOutlook As New Outlook.Application
　　Dim objMail As MailItem
　　"取得当前工作表与Cells(1,1)相连的数据区行数
　　endRowNo = Cells(1, 1).CurrentRegion.Rows.Count
　　"创建objOutlook为Outlook应用程序对象
　　Set objOutlook = New Outlook.Application
　　"开始循环发送电子邮件
　　For rowCount = 2 To endRowNo
　　"创建objMail为一个邮件对象
　　Set objMail = objOutlook.CreateItem(olMailItem)
　　With objMail
　　"设置收件人地址（从通讯录表的“E-mail地址”字段中获得）
　　.To = Cells(rowCount, 2)
　　"设置邮件主题
　　.Subject ="新年好！[来自朋友弗人的问候] "
　　"设置邮件内容（从通讯录表的“内容”字段中获得）
　　.Body = Cells(rowCount, 3)
　　"设置附件（从通讯录表的“附件”字段中获得）
　　.Attachments.Add Cells(rowCount, 4)
　　"自动发送邮件
　　.Send
　　End With
　　"销毁objMail对象
　　Set objMail = Nothing
　　Next
　　"销毁objOutlook对象
　　Set objOutlook = Nothing
　　"所有电子邮件发送完成时提示
　　MsgBox rowCount-1