| |
* 답변하시는 분들께 도움이 되도록 자신의 환경을 아래 항목 옆에 기재해 주세요.
- 엑셀 버전(95,97,2000,xp,2003,2007):
* 아래줄에 질문을 작성하세요 >>
한개의 엑셀파일을 잘라서 일부씩 여러명에게 메일보내기가 가능한지?
꼭 가능했으면 좋겠습니다.
질문파일 봐주세요.
==============[시커미소님 글에 대한 답변입니다]==============
첨부화일 참고하세요....
Sub Mail_Range()
Dim wbk As Workbook, wbkDest As Workbook
Dim rDb As Range, rSoc As Range, rCri As Range, rX As Range
Dim sFilePath As String, sFileName As String
Dim sExt As String
Dim lFileFormat As Long
Dim OutApp As Object, OutMail As Object
Dim sSubject As String
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
Set wbk = ActiveWorkbook
Set rDb = wbk.Worksheets("내역").Range("A2").CurrentRegion
Set rCri = wbk.Worksheets("Email주소").Range("A2").CurrentRegion
Set rCri = rCri.Offset(1).Resize(rCri.Rows.Count - 1).Columns(4)
If rDb.Parent.AutoFilterMode Then rDb.Parent.AutoFilterMode = False
If Val(Application.Version) < 12 Then
sExt = ".xls": lFileFormat = xlWorkbookNormal ' Excel 97-2003
Else
sExt = ".xlsx": lFileFormat = xlOpenXMLWorkbook ' Excel 2007-2016
End If
sFilePath = Environ$("temp") & Application.PathSeparator
Set OutApp = CreateObject("Outlook.Application")
For Each rX In rCri.Cells
Set OutMail = OutApp.CreateItem(0)
rDb.AutoFilter Field:=5, Criteria1:=rX.Value
Set rSoc = rDb.SpecialCells(xlCellTypeVisible)
Set wbkDest = Workbooks.Add(xlWBATWorksheet)
sFileName = rX.Value & "_" & Format(Now, "yyyymmdd_hhmmss")
sSubject = rX.Offset(, -2) & "_" & rX.Offset(, -1) & "_" & rX.Offset(, 0)
rSoc.Copy
With wbkDest
With .Sheets(1)
.Cells(1).PasteSpecial Paste:=xlPasteColumnWidths
.Cells(1).PasteSpecial Paste:=xlPasteValues
.Cells(1).PasteSpecial Paste:=xlPasteFormats
.Cells(1).Select
End With
Application.CutCopyMode = False
.SaveAs sFilePath & sFileName & sExt, lFileFormat
On Error Resume Next
With OutMail
.To = rX.Offset(, -3)
.CC = ""
.Bcc = ""
.Subject = sSubject
.Body = sSubject & " 담당자의 현황 리스트입니다."
.Attachments.Add wbkDest.FullName
'.Send ' 메일 보내기
.Display
End With
On Error GoTo 0
.Close False
End With
Set OutMail = Nothing
Kill sFilePath & sFileName & sExt
Next
If rDb.Parent.AutoFilterMode Then rDb.Parent.AutoFilterMode = False
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub |
|
엑셀에 대한 질문과
답변을 올려주세요. 단, 취지에 맞지 않는 글은 운영자가 삭제합니다.
