이메일 주소를 기준으로 행을 선택하고 해당 주소로 메일을 보내야 합니다. 워크시트를 이메일로 보내는 코드만 있습니다.
이미지는 샘플 파일입니다. 매크로는 'BA' 열을 기준으로 행을 선택하고 해당 전자 메일 ID로 보내야 합니다.
Sub Mail_to_recipients()
Dim OutApp As Object
Dim OutMail As Object
Dim myDataRng As Range
Dim cell As Range
Dim iCnt As Integer
Dim sMail_ids As String
Dim TempFilePath As String
Dim FileExt As String
Dim TempFileName As String
Dim FileFullPath As String
Dim FileFormat As Variant
Dim Wb1 As Workbook
Dim Wb2 As Workbook
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set Wb1 = ThisWorkbook
ActiveSheet.Copy
Set Wb2 = ActiveWorkbook
'Below code will get the File Extension and
'the file format which we want to save the copy
'of the workbook with the active sheet.
With Wb2
If Val(Application.Version) < 12 Then
FileExt = ".xls": FileFormat = -4143
Else
Select Case Wb1.FileFormat
Case 51: FileExt = ".xlsx": FileFormat = 51
Case 52:
If .HasVBProject Then
FileExt = ".xlsm": FileFormat = 52
Else
FileExt = ".xlsx": FileFormat = 51
End If
Case 56: FileExt = ".xls": FileFormat = 56
Case Else: FileExt = ".xlsb": FileFormat = 50
End Select
End If
End With
'Save your workbook in your temp folder of your system
'below code gets the full path of the temporary folder
'in your system
TempFilePath = Environ$("temp") & "\"
'Now append a date and time stamp
'in your new file
TempFileName = Wb1.Name & "-" & Format(Now, "dd-mmm-yy h-mm-ss")
'Complete path of the file where it is saved
FileFullPath = TempFilePath & TempFileName & FileExt
'Now save your currect workbook at the above path
Wb2.SaveAs FileFullPath, FileFormat:=FileFormat
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Set myDataRng = Range("AJ5:AJ10" & Cells(Rows.Count, "AJ").End(xlUp).Row)
' Run a loop to extract email ids from the 2nd column.
For Each cell In myDataRng
If Trim(sMail_ids) = "" Then
sMail_ids = cell.Offset(1, 0).Value
Else
sMail_ids = sMail_ids & vbCrLf & ";" & cell.Offset(1, 0).Value
End If
Next cell
Set myDataRng = Nothing ' Clear the range.
On Error Resume Next
With OutMail
.To = sMail_ids
.CC = ""
.BCC = ""
.Subject = "Weekindeling week " & Range("K1")
.Attachments.Add FileFullPath
.Display
End With
On Error GoTo 0
'Since mail has been sent with the attachment
'Now close and delete the temp file from the
'temp folder
Wb2.Close SaveChanges:=False
Kill FileFullPath
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
답변1
아래 코드는 완전하지 않습니다. 전체 설명에는 작동 방식과 편집 방법이 설명되어 있습니다. 지금은 각 사용자의 데이터가 포함된 파일을 생성하는 것이 전부입니다. 실제로 각 사용자에게 파일을 이메일로 보내는 방법에 대한 부분을 추가해야 합니다.
Sub sendEmailToEachUser()
' Save the unique list of emails
' This will include the column header in the first value and a blank somewhere (probably at the end) unless there isn't a blank in the entire column, which is unlikely
' You should change "C:C" to your actual range reference. You could also reference the table field here if you want.
Dim arrEmails() As Variant
arrEmails = WorksheetFunction.Unique([C:C])
' Save the autofilter range for easy reference later
' Again, update the sheet reference here from "Sheet1" to the codename of whatever sheet you want to use
Dim filterRange As Range
Set filterRange = Sheet1.AutoFilter.Range
' Save a timestamp to add to the file names
' This is not necessary but it's nice
Dim timeStamp As String
timeStamp = Format(Now, "yyyy-mm-dd hhMMss")
' Filter by each email, one at a time
' We skip the first (because that's the column header) and the blank whenever we come to it
Dim i As Long
Dim userEmail As String
Dim wb As Workbook
Dim fileName As String
For i = LBound(arrEmails) + 1 To UBound(arrEmails)
' Save the user's email
' The unique list is technically an array of arrays since it's a range so we have to pull the first from each row with (i, 1)
userEmail = arrEmails(i, 1)
' Check for the blank and skip it
If Len(userEmail) > 0 Then
' Filter for just that email address
filterRange.AutoFilter Field:=3, Criteria1:=userEmail
' Create a new workbook
Set wb = Workbooks.Add
' Get all the data that's showing
filterRange.Copy wb.Worksheets(1).Range("A1")
' Save the file with the data
' Edit the file name as you wish
' You could make the unique function above pull user name *and* user email so you can use the user name as the file name
fileName = userEmail & " " & timeStamp
wb.SaveAs fileName
' You now have a workbook saved with just one user's data
' You have the file name so you can attach it to an email for that user
' You'd have a line somewhere in your code like these:
' .To = userEmail
' .Attachments.Add fileName
' You may have to add the full path to that "fileName"
' You can delete the file once it's added, too
' Add whatever you want to here inside the loop so it'll happen for each email address in your list
End If
Next
End Sub