マクロ Outlook メールの一斉送信について

Question

前提・実現したいこと

①マクロを使ってアウトルックのメールの一斉送信を行いたいです。
②宛先ごとに本文の内容を一部変更したいです。
コードは下記のサイトを参考にしました。
https://moripro.net/vba-outlook-createmail/

発生している問題・エラーメッセージ

１つの「氏名」に対して、「使用日」や「金額」にあたる数字が複数ある場合、
どのようにコードを書いたら良いでしょうか。

Dim mBody As String 'メール本文
    mBody = Cells(2, "J").Value '初期値を設定
    mBody = Replace(mBody, "（氏名）", sName)
    mBody = Replace(mBody, "（使用日）", DayOfUse)
    mBody = Replace(mBody, "（金額）", price)
    mBody = mBody & vbCrLf & vbCrLf & sign '末尾に署名を付与

該当のソースコード

Enum col '1以降の数値を省略した場合は+1される
    宛先 = 1
    複写
    氏名
    使用日
    金額
End Enum
 
Sub Outlookメール一括作成()
 
    Dim OutlookObj As Outlook.Application 'Outlookオブジェクトの作成
    Set OutlookObj = New Outlook.Application
    
    Dim r As Long
    For r = 2 To Cells(1, 1).End(xlDown).Row '対象人数分の処理を繰り返す
    
        Dim mailItemObj As Outlook.MailItem 'メールアイテムオブジェクト作成
        Set mailItemObj = OutlookObj.CreateItem(olMailItem)
 
        Dim mailBody As String
        mailBody = CreateMailBody(r) 'メール本文作成
        
        With mailItemObj 'メールアイテム作成
            .To = Cells(r, col.宛先).Value 'Toを設定
            .CC = Cells(r, col.複写).Value 'CCを設定
            .Subject = Cells(1, "J").Value '件名を設定
            .Body = mailBody '本文を設定
        End With
        
        mailItemObj.Display '下書きを表示
        
        '次のメールアイテムを作成するためいったん破棄
        Set mailItemObj = Nothing
    
    Next r
 
End Sub
 
Function CreateMailBody(r As Long) As String
' 機能：Excelシート上の指定行番号のメール本文を作成する
 
    Dim sName As String, DayOfUse As String, price As Long
    sName = Cells(r, col.氏名).Value
    DayOfUse = Cells(r, col.使用日).Value
    price = Cells(r, col.金額).Value
    
    Dim sign As String '署名
    sign = Cells(12, "J").Value
    
    Dim mBody As String 'メール本文
    mBody = Cells(2, "J").Value '初期値を設定
    mBody = Replace(mBody, "（氏名）", sName)
    mBody = Replace(mBody, "（使用日）", DayOfUse)
    mBody = Replace(mBody, "（金額）", price)
    mBody = mBody & vbCrLf & vbCrLf & sign '末尾に署名を付与
    
    CreateMailBody = mBody
 
End Function

試したこと

ワークシートの行を増やしてみましたがズレてしまいます。１つの「氏名」に対して複数「金額」や「使用日」が
ある場合もあれば、当該項目が１つのみの場合もある状況です。

補足情報（FW/ツールのバージョンなど）

マクロ初心者です。上記の方法をご存知でしたらご教示いただけますと幸いです。
よろしくお願いいたします。

Answer 1

こんな感じで

Enum col '1以降の数値を省略した場合は+1される
    宛先 = 1
    複写
    氏名
    使用日
    金額
End Enum

Sub Outlookメール一括作成()

  Dim OutlookObj As Outlook.Application 'Outlookオブジェクトの作成
  Set OutlookObj = New Outlook.Application
  
  'リスト範囲
  Dim rngFrom As Range, setRng As Range, trgRng As Range
  Set rngFrom = ActiveSheet.Range("A1").CurrentRegion 'データー範囲
  Set setRng = Intersect(rngFrom.SpecialCells(xlCellTypeConstants), rngFrom.Offset(1), rngFrom.Range("A:A")) '（データーのある行ｘ１行下ｘＡ列）＝送信メールのある行
  
  '宛先のある行を配列に収める
  Dim setRow
  ReDim setRow(setRng.Count)
  i = 0
  For Each trgRng In setRng
    setRow(i) = trgRng.Row
    i = i + 1
  Next
  setRow(i) = Cells(1, 4).End(xlDown).Row + 1 '最後に票の下の行
  
  'メール作成開始
  Dim r As Long, nr As Long
  For i = 0 To UBound(setRow) - 1
    r = setRow(i)      '対象開始行
    nr = setRow(i + 1) '対象終了行
    Dim mailItemObj As Outlook.MailItem 'メールアイテムオブジェクト作成
    Set mailItemObj = OutlookObj.CreateItem(olMailItem)
  
    Dim mailBody As String
    mailBody = CreateMailBody(r, nr) 'メール本文作成
    
    With mailItemObj 'メールアイテム作成
      .To = Cells(r, col.宛先).Value 'Toを設定
      .CC = Cells(r, col.複写).Value 'CCを設定
      .Subject = Cells(1, "J").Value '件名を設定
      .Body = mailBody '本文を設定
    End With
    
    mailItemObj.Display '下書きを表示
    
    '次のメールアイテムを作成するためいったん破棄
    Set mailItemObj = Nothing
   
  Next

End Sub

Function CreateMailBody(r As Long, nr As Long) As String

' 機能：Excelシート上のｒ行番目からｎｒ－１行目までの明細のメール本文を作成する

  Dim sName As String, DayOfUse As String, Price As String
  sName = Cells(r, col.氏名).Value
  For i = r To nr - 1 '桁を揃えて連結
     DayOfUse = Format(Cells(i, col.使用日).Text, "yyyy/mm/dd")
     Price = Right("                " & Format(Cells(i, col.金額).Value, "###,###,##0"), 14)
     strData = strData & DayOfUse & Price & vbCrLf
  Next
  
  Dim sign As String '署名
  sign = Cells(12, "J").Value

  Dim mBody As String 'メール本文
  mBody = Cells(2, "J").Value '初期値を設定
  mBody = Replace(mBody, "（氏名）", sName)
  mBody = Replace(mBody, "（DATA）", strData)
  mBody = mBody & vbCrLf & vbCrLf & sign '末尾に署名を付与
  CreateMailBody = mBody

End Function

Comments

[ponsuke0025]

新蔵さま
早速のご回答、ありがとうございます。早速試してみたいと思います。大変助かりました。
ありがとうござました！