[ExcelVBA]脱FAXの第一歩。複数宛先のメールメッセージを生成する方法

=IF(WEEKDAY(TODAY()+$B$4,2)=6,TODAY()+$B$4+2,IF(WEEKDAY(TODAY()+$B$4,2)=7,TODAY()+$B$4+1,TODAY()+$B$4))

="回答希望："&TEXT(D4,"yyyy/mm/dd")

Sub ボタン1_Click()
  Dim MAINROW As Long
  Dim TOUSHI_STR As String
  Dim LOGROW As Long
  
  Dim OL As Outlook.Application
  Dim MI As Outlook.MailItem
  
  Dim RET As Long
  Dim SENDFILEPATH As Variant
  
  Set OL = CreateObject("Outlook.Application")
  
  LOGROW = 1
  Do Until Worksheets("LOG").Cells(LOGROW, 1).Value = ""
    LOGROW = LOGROW + 1
  Loop
  
  OPENFOLDER = Worksheets("メイン").Range("B6").Value
  If OPENFOLDER <> "" Then
    If Dir(OPENFOLDER, vbDirectory) <> "" Then
      If InStr(OPENFOLDER, "\\") > 0 Then
        'ネットワーク上
        With CreateObject("WScript.Shell")
          .CurrentDirectory = OPENFOLDER
        End With
      Else
        'ローカル
        ChDir (OPENFOLDER)
      End If
    End If
  End If
  
  '添付ファイル
  RET = MsgBox("ファイルを添付しますか？", vbYesNo)
  If RET = 6 Then
    SENDFILEPATH = Application.GetOpenFilename(, , "添付するファイルを選択してください", MultiSelect:=True)
    If Not IsArray(SENDFILEPATH) Then
      RET = 7
    End If
  End If
  
  With Worksheets("メイン")
    '通し番号
    If .Range("F1").Value = Date Then
      .Range("H1").Value = .Range("H1").Value + 1
      TOUSHI_STR = CStr(Date) & "-" & CStr(.Range("H1").Value)
    Else
      .Range("F1").Value = Date
      .Range("H1").Value = 1
      TOUSHI_STR = CStr(Date) & "-1"
    End If
    
    MAINROW = 10
    Do Until .Cells(MAINROW, 2).Value = ""
      If .Cells(MAINROW, 1).Value <> "" Then
        Set MI = OL.CreateItem(olMailItem)
        MI.To = .Cells(MAINROW, 2).Value
        MI.Subject = .Range("B1").Value & " " & TOUSHI_STR
        MI.Body = .Cells(MAINROW, 3).Value & " " & .Cells(MAINROW, 4).Value & vbLf & vbLf & .Range("B2").Value & vbLf & vbLf & .Range("B3").Value & vbLf & vbLf & .Range("E4").Value & CStr(.Range("F4").Value) & vbLf & vbLf & .Range("B5").Value
        '添付ファイル貼り付け
        If RET = 6 Then
          If SENDFILEPATH(1) <> "" Then
            For Each ADDFILE In SENDFILEPATH
              MI.Attachments.Add ADDFILE
            Next
          End If
        End If
        MI.Display
        '宛先選択をクリア
        .Cells(MAINROW, 1).Value = ""
        
        'LOGシートに転記
        Worksheets("LOG").Cells(LOGROW, 1).Value = TOUSHI_STR
        Worksheets("LOG").Cells(LOGROW, 2).Value = .Cells(MAINROW, 3).Value & " " & .Cells(MAINROW, 4).Value
        LOGSTR = Replace(.Range("B3").Value, vbLf, " ")
        Worksheets("LOG").Cells(LOGROW, 3).Value = LOGSTR
        LOGROW = LOGROW + 1
        
      End If
      MAINROW = MAINROW + 1
    Loop
  
  End With
  
  Set OL = Nothing
  Set MI = Nothing
  
End Sub