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

谢谢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" & "
" & _

"This is line 2" & "
" & _

"This is line 3" & "
"

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

我希望这对某人有用 .