Ich muss Zeilen basierend auf der E-Mail-Adresse auswählen und an diese Adresse senden. Ich habe nur Code, der ein Arbeitsblatt per E-Mail sendet
Das Bild ist die Beispieldatei. Das Makro muss die Zeilen basierend auf der Spalte „BA“ auswählen und an die entsprechende E-Mail-ID senden
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
Antwort1
Der folgende Code ist nicht vollständig. Kommentare erklären, wie er funktioniert und wie Sie ihn bearbeiten müssen. Im Moment erstellt er lediglich eine Datei mit den Daten jedes Benutzers. Sie müssen noch die Details zum tatsächlichen Versenden der Dateien per E-Mail an jeden Benutzer hinzufügen.
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