열 A에받는 사람 이름, 열 B에받는 사람 전자 메일 및받는 사람에게 전자 메일로 보낼 정보가있는 다른 스프레드 시트가 있습니다. 각받는 사람은 여러 행을 가지며받는 사람 당 행 수는 매번 다릅니다. 수신자 수 또한 다양합니다.Excel VBA - 열에 대응하는 테이블로 전자 메일링 범위
각받는 사람마다 하나의 전자 메일 만 만들고 해당받는 사람과 관련된 다른 데이터 열은 전자 메일 본문 끝에 테이블로 포함됩니다. 모든 전자 메일에는 스프레드 시트가 아니라 코드에 저장된 전자 메일 본문에 같은 텍스트가 있습니다.
도움을 주시면 감사하겠습니다. Excel VBA를 통해 Outlook을 처음 다루는 것입니다.
감사
감사합니다. 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
이 하위 이메일은 실제로 이메일을 생성하여 보냅니다.
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
다른 사람에게 유용하기를 바랍니다.
스프레드 시트의 모양을 표시 할 수 있습니까? – 0m3r