首页 文章

Excel VBA - 通过电子邮件发送范围作为列中对应电子邮件的表

提问于
浏览 次
0

我有一个电子表格，其中收件人姓名列在A栏，收件人电子邮件列在B栏，多个其他列包含要通过电子邮件发送给这些收件人的信息 . 每个收件人都有多行，每个收件人的行数每次都不同 . 收件人数也各不相同 .

我想要做的是为每个收件人只创建一封电子邮件，并将与该收件人相关的其他数据列作为电子邮件正文末尾的表格包含在内 . 所有电子邮件在电子邮件正文中都有相同的文本，这些文本将存储在代码中而不是电子表格中 .

任何帮助，将不胜感激 . 这是我第一次通过Excel VBA处理outlook .

谢谢

excel vba excel-vba email outlook

2 回答

  • 0

    • 在VBA中添加对outlook库的引用（在工具栏 - >工具 - >引用 - Microsoft Outlook中）

    • 收件人将是过滤器（如果电子邮件发送给同一个人，只要坚持你想对他/她说的所有事情），那么，为什么不在第一次获取它们之前做一个过滤器地点？

    • 添加引用后，您将可以使用outlook命令，创建实例等 . 有are many google examples，这个可能是一个很好的开始 . 这是我建议的工作流程

    回复于
  • 0

    谢谢Sgdva . 这是一个很好的暗示 . 我还使用了Ron de Bruin的一些代码来提出以下解决方案 .

    此子设置我的数据并且与答案不太相关，但可能对某人有用 .

    Sub Related_BA()

Dim wb As Workbook
Dim ws As Worksheet
Dim filename As Variant
Dim returnVAlue As Variant
Dim BAwb As Workbook
Dim BAws As Worksheet
Dim BArng As Range
Dim LastRow As Integer
Dim i As Integer

Set wb = ActiveWorkbook
Set ws = wb.Worksheets("Super User Report")

filename = Application.GetOpenFilename(filefilter:="Excel Files (*xls), *xls", Title:="Please select BA refernce file")
If filename = False Then Exit Sub

ws.Range("A:B").EntireColumn.Insert

Set BAwb = Application.Workbooks.Open(filename)
Set BAws = BAwb.Worksheets("Sheet1")
Set BArng = BAws.ListObjects("DepartmentBA").DataBodyRange

With ws.Cells(1, 1)
    .Value = "BA"
    .HorizontalAlignment = xlCenter
    .Font.Bold = True
End With

With ws.Cells(1, 2)
    .Value = "BA Email"
    .HorizontalAlignment = xlCenter
    .Font.Bold = True
End With

LastRow = ws.Range("C1").CurrentRegion.Rows.Count

On Error Resume Next
For i = 2 To LastRow
    ws.Cells(i, 1) = Application.WorksheetFunction.VLookup(ws.Cells(i, 6), BArng, 2, 0)
Next i

On Error Resume Next
For i = 2 To LastRow
    ws.Cells(i, 2) = Application.WorksheetFunction.VLookup(ws.Cells(i, 6), BArng, 3, 0)
Next i

BAwb.Close False

ws.Columns("A:B").EntireColumn.AutoFit

ws.Range("B2").CurrentRegion.Sort key1:=ws.Range("B2"), order1:=xlAscending, _
    key2:=ws.Range("C2"), order2:=xlAscending, Header:=xlYes

Call SendEmail

ws.Range("A:B").EntireColumn.Delete


End Sub

    这格式化电子邮件的数据并调用电子邮件功能 . 我仍然可能需要代码来处理来自vlookup的#N / A.

    Sub SendEmail()

Dim cBA As Collection
Dim rng As Range
Dim cell As Range
Dim wb As Workbook
Dim ws As Worksheet
Dim vNum As Variant
Dim lRow As Integer

Set wb = ActiveWorkbook
Set ws = wb.Worksheets("Super User Report")
lRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Set rng = ws.Range("A2:A" & lRow)
Set cBA = New Collection

On Error Resume Next
    For Each cell In rng.Cells
        cBA.Add cell.Value, CStr(cell.Value)
    Next cell
On Error GoTo 0

On Error Resume Next
cBA.Remove ("None")

Worksheets("Super User Report").AutoFilterMode = False

For Each vNum In cBA
    rng.AutoFilter Field:=1, Criteria1:=vNum
    Call Email(vNum)
    rng.AutoFilter Field:=1
Next vNum


End Sub

    该sube实际上创建并发送电子邮件 .

    Sub Email(BA As Variant)

Dim wb As Workbook
Dim ws As Worksheet
Dim lRow As Integer
Dim StrBody As String
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim Mnth As Variant
Dim Yr As Variant

StrBody = "This is line 1" & "<br>" & _
          "This is line 2" & "<br>" & _
          "This is line 3" & "<br><br><br>"


Mnth = Format(Month(Date), "mmmm")
Yr = Year(Date)
Set wb = ActiveWorkbook
Set ws = wb.Worksheets("Super User Report")
lRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Set rng = Nothing
On Error Resume Next
'Only the visible cells in the selection
Set rng = ws.Range("C1:L" & lRow).SpecialCells(xlCellTypeVisible)
'You can also use a fixed range if you want
'Set rng = Sheets("YourSheet").Range("D4:D12").SpecialCells(xlCellTypeVisible)
On Error GoTo 0

If rng Is Nothing Then
    Exit Sub
End If

With Application
    .EnableEvents = False
    .ScreenUpdating = False
End With

rng.Borders(xlDiagonalDown).LineStyle = xlNone
rng.Borders(xlDiagonalUp).LineStyle = xlNone
With rng.Borders(xlEdgeLeft)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlThin
End With
With rng.Borders(xlEdgeTop)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlThin
End With
With rng.Borders(xlEdgeBottom)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlThin
End With
With rng.Borders(xlEdgeRight)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlThin
End With
With rng.Borders(xlInsideVertical)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlThin
End With
With rng.Borders(xlInsideHorizontal)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlThin
End With

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

Mnth = Format(Month(Date), "mmmm")
Yr = Year(Date)

On Error Resume Next
With OutMail
    .To = BA
    .CC = ""
    .BCC = ""
    .Subject = "Monthly Super User Report " & Mnth & " " & Yr
    .HTMLBody = StrBody & RangetoHTML(rng)
    .Display   'or use .Send
End With
On Error GoTo 0

rng.Borders(xlDiagonalDown).LineStyle = xlNone
rng.Borders(xlDiagonalUp).LineStyle = xlNone
rng.Borders(xlEdgeLeft).LineStyle = xlNone
rng.Borders(xlEdgeTop).LineStyle = xlNone
rng.Borders(xlEdgeBottom).LineStyle = xlNone
rng.Borders(xlEdgeRight).LineStyle = xlNone
rng.Borders(xlInsideVertical).LineStyle = xlNone
rng.Borders(xlInsideHorizontal).LineStyle = xlNone

With Application
    .EnableEvents = True
    .ScreenUpdating = True
End With

Set OutMail = Nothing
Set OutApp = Nothing
End Sub

    该功能在上面的子目录中引用 .

    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"

'Copy the range and create a new workbook to past the data in
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

'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 the 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=")

'Close TempWB
TempWB.Close savechanges:=False

'Delete the htm file we used in this function
Kill TempFile

Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function

    我希望这对某人有用 .

    回复于

相关问题