☰

Excel VBA を使用して一括メールを送信する

tag-icon • tag-icon vba microsoft-excel-2013 macros
Excel VBA を使用して一括メールを送信する

条件が満たされた場合にさまざまな人に大量のメールを送信するプロジェクトに取り組んでいました。

条件：

  • 列 U には最終ステータス (オープンまたは WIP) が含まれます (現在の日付が大きくてもクローズの場合は送信されません)
  • 列 Q には終了日が含まれています。現在の日付と比較して、短い場合は自動的に人々にメールが送信されます。

for ループで実行しようとしましたが、同じ宛先と CC を持つ 4 通のメールが送信され、比較のために次の行に進みません。

セルV2とQ2を比較し、次にV3とQ3をループし、同じ方法でセルU2が「開いている」かどうかを確認します。

よろしくお願いします。

コードは以下のとおりです。

Sub Data_RoundedRectangle1_Click()

Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim StrBody As String



On Error Resume Next

For i = 1 to 4

If Sheets("Data").Range("U2:U6").Value2 = "Open" Or     Sheets("Data").Range("U2:U6").Value2 = "WIP" And (CDate(Cells(2, 17).Value) <     Now()) Then



        Set rng = Nothing
        On Error Resume Next
        'Only the visible cells in the selection
        Set rng = Selection.SpecialCells(xlCellTypeVisible)
        'You can also use a fixed range if you want
        Set rng = Sheets("Checklist").Range("A2:B25").SpecialCells(xlCellTypeVisible)
        On Error GoTo 0


        With Application
        .EnableEvents = False
        .ScreenUpdating = False
        End With

        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)

        On Error Resume Next

With OutMail


        If Worksheets("Data").Cells(i, "C").Value2 = "Operation_Support" And Worksheets("Data").Cells(i, "E").Value2 = "Quality_Assurance" Then


     StrBody = "Hi," & "<br>" & _


.To = "a"

.CC = "b"
.BCC = ""
.Subject = ""
.HTMLBody = StrBody & RangetoHTML(rng)
.Attachments.Add ActiveWorkbook.FullName
' You can add other files by uncommenting the following line.
'.Attachments.Add ("C:\test.txt")
.Display
'.Send

ElseIf Worksheets("Data").Cells(i, "C").Value = "Operation_Support" And Worksheets("Data").Cells(i, "E").Value = "Analytics" Then

StrBody = "Hi," & "<br>" & _
      "PFB the process details which requires your attention." & "<br>" & _
      "The review for this process has crossed over due." & "<br>" & _
      "Please ask the process owner to review the Process Manuals and Maps."     & "<br><br><br>"

.To = "c"

.CC = "d"
.BCC = ""
.Subject = "Process Manual and Maps Review is Overdue"
.HTMLBody = StrBody & RangetoHTML(rng)
.Attachments.Add ActiveWorkbook.FullName
' You can add other files by uncommenting the following line.
'.Attachments.Add ("C:\test.txt")
.Display
'.Send

End If

    End With

    i = i + 1
    Exit For

    End If
End If

Next r

On Error GoTo 0

With Application
    .EnableEvents = True
    .ScreenUpdating = True
End With

Set OutMail = Nothing
Set OutApp = Nothing

Next x
End Sub

ここに画像の説明を入力してください

答え1

それはあなたのループのせいだと思います

For i = 1 to 4

しかし、あなたは決して参照しないiので、それはすべて4回繰り返します。代わりに次のように使用してください -

If Sheets("Data").cells(21,1+i).Value2 = "Open" Or Sheets("Data").cells(21,1+i).Value2 = "WIP" And ...

2 番目の部分が何を指しているのかはよくわかりませんifが、要点はわかります。

関連情報