返信状況確認

Sub CopyEmailContentsToSheet()
Dim OutlookApp As Object
Dim OutNamespace As Object
Dim SharedInbox As Object
Dim MailItem As Object
Dim ws As Worksheet
Dim i As Long, j As Integer
Dim Found As Boolean

On Error GoTo ErrorHandler

' Excelシートの設定
Set ws = ThisWorkbook.Sheets("メール送付_一括送付")

' Outlookのインスタンスを開始
Set OutlookApp = CreateObject("Outlook.Application")
Set OutNamespace = OutlookApp.GetNamespace("MAPI")

' 共有アカウントのメールアドレスを設定
Dim SharedMailboxAddress As String
SharedMailboxAddress = "shared@domain.com"

' 共有アカウントの受信トレイを取得
Set SharedInbox = OutNamespace.GetSharedDefaultFolder(OutNamespace.CreateRecipient(SharedMailboxAddress), 6) ' 6は受信トレイ

' Excelシートをループ処理
For i = 2 To ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
If ws.Cells(i, "E").Value <> "" Then ' E列が空欄でない場合のみ処理
Found = False
j = 0

' メールアイテムをループ処理
For Each MailItem In SharedInbox.Items
If InStr(MailItem.Subject, ws.Cells(i, "E").Value) > 0 And (MailItem.SenderEmailAddress = ws.Cells(i, "B").Value Or MailItem.SenderEmailAddress = ws.Cells(i, "C").Value Or MailItem.SenderEmailAddress = ws.Cells(i, "D").Value) Then
' メールの内容を転記
j = j + 1
If j > 3 Then
MsgBox "該当メールが4件以上あります"
Exit Sub
End If
ws.Cells(i, "F").Offset(0, j - 1).Value = MailItem.Body
Found = True
End If
Next MailItem

' 該当メールがない場合の処理
If Not Found Then
ws.Cells(i, "F").Interior.Color = RGB(255, 255, 0) ' 黄色に着色
End If
End If
Next i

GoTo CleanUp

ErrorHandler:
MsgBox "エラーが発生しました: " & Err.Description
GoTo CleanUp

CleanUp:
' オブジェクトの解放
Set SharedInbox = Nothing
Set OutNamespace = Nothing
Set OutlookApp = Nothing
End Sub
```

この修正により、該当するメールが見つからなかった場合に、該当行のE列のセルが黄色に着色されます。これにより、視覚的に該当メールがない行を簡単に識別できます。