1つの列のデータをグループ化して特定の行を選択し、その選択を電子メールで送信するVBAコードが必要です

Question

メールアドレスに基づいて行を選択し、そのアドレスにメールする必要があります。ワークシートをメールに送信するコードしかありません。

画像はサンプルファイルです。マクロは列「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

Answer 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