[[20230527191732]]　『Excelでタスク管理を作成しています』（白ご飯）　ページの最後に飛ぶ

『Excelでタスク管理を作成しています』（白ご飯）

Excelでタスク管理を作成しています。
アプリで色々ありますが会社が認めてくれないためExcelでタスク管理を作成しようと考えました。
1ヵ月シートに
B列にタスク
C列に部署
D列に担当者
E列にタスクの予定開始日
F列に予定終了日
G列に担当者がタスクに取り掛かった日付
H列に担当者がタスクが完了した日付
を作成しています。
別のメニューシートで更新を行うと1ヵ月シートに反映させることができます。
Private Sub kousin_Click()

    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim r As Range, wsName As Variant
    Dim rMaxBelow As Range
    'プログラム2｜シート設定
    Set ws1 = ThisWorkbook.Worksheets("メニュー")
    Set r = ws1.Range("C6:C12")
    If Application.CountBlank(r) > 0 Then
        MsgBox "未入力セルがあるので、入力すること"
        Exit Sub
    End If
    For Each wsName In Array("1ヵ月")
        Set ws2 = Worksheets(wsName)
        Select Case wsName
            Case "1ヵ月"
                ws2.Cells(ws2.Rows.Count, "I").End(xlUp).Offset(1).Value = ws1.Range("C11").Value
                ws2.Cells(ws2.Rows.Count, "J").End(xlUp).Offset(1).Value = ws1.Range("C12").Value

        End Select
        With ws2.Cells(ws2.Rows.Count, "B").End(xlUp).Offset(1)
            .Resize(, 5).Value = Application.Transpose(r.Value)
        End With
    Next
    ThisWorkbook.Save
End Sub
そこで更新後、指定された担当者に自動でメールを送りたいと思うのですがそんなことできるのでしょうか。
色々調べてますができないため相談させていただきました。
よろしくお願いします。

＜使用 Excel：Microsoft365、使用 OS：Windows10 ＞

できるかできないかで言えばできます。

ぱっと思い浮かぶ方法は
１．ExcelからOutlookを起動してOutlookでメールを送る。
２．CDOを使ってメールを送る。
３．BASP21などのdllを使ってメールを送る。
の3つです。

１　⇒　外部のナニカを使用することなくVBAだけで完結でき、メールサーバー側の制約も少ないが、ちょっと不便。
２　⇒　Microsoftの標準的な機能で完結できるが、メールサーバー側の制約がある。
３　⇒　使いやすいものが多いが、外部のナニカを使うことになる。

です。
（高橋） 2023/05/27(土) 19:37:00

ありがとうございます。
試しに下記で試してみたのですができなかったです。
D列に直接アドレスを入れてもダメでした。
Sub SendEmail()

    Dim OutlookApp As Object
    Dim OutlookMail As Object
    Dim LastRow As Long
    Dim i As Long

    ' Outlookアプリケーションを作成
    Set OutlookApp = CreateObject("Outlook.Application")
    ' 新しいメールを作成
    Set OutlookMail = OutlookApp.CreateItem(0)

    ' 最終行を取得
    LastRow = Cells(Rows.Count, "D").End(xlUp).Row

    ' ループして条件をチェックし、メールを送信
    For i = 8 To LastRow
        If Cells(i, "E").Value <> "" And Cells(i, "F").Value <> "" Then
            ' D列の担当者にメールを送信
            With OutlookMail
                .To = Cells(i, "D").Value
                .Subject = "タイトル"
                .Body = "本文"
                ' メールを送信
                .Send
            End With
        End If
    Next i

    ' メモリを解放
    Set OutlookMail = Nothing
    Set OutlookApp = Nothing
End Sub
（白ご飯） 2023/05/27(土) 19:47:38

おはようございます。
メール送信できるようにしたいためお願いします
（白ご飯） 2023/05/28(日) 07:57:27

https://fastclassinfo.com/entry/excelvba_outlook_sendmails/
などが参考になりませんか？

（xyz） 2023/05/28(日) 08:19:25

 メール送信だけならちょっと前に回答したコード少し変えて、こんな感じでどうですかね？
[[20230517083855]]　『EXCELのシートからデータを読み取ってOUTLOOKの下』（超素人なぼくちゃん）

    Option Explicit
    Sub メール下書き連続生成()
        Dim ws As Worksheet
        Dim dic As Object: Set dic = CreateObject("Scripting.Dictionary")
        Dim k As Variant
        Dim lRow As Long, i As Long
        Dim w As Variant
        Dim msg As String
        Const lStartRow As Long = 8
        If OutLookChk = False Then
            MsgBox "OutLookを開いてから実行してください"
        End If

        Set ws = Sheets("Sheet1")
        lRow = ws.Cells(Rows.Count, "D").End(xlUp).Row

        'dic(宛先) = 本文
        For i = lStartRow To lRow
            w = WorksheetFunction.Index(ws.Range("D:F"), i, 0)
            w = Application.Transpose(Application.Transpose(w))
            If w(2) <> "" And w(3) <> "" Then
                dic(w(1)) = dic(w(1)) & "本文" & Chr(10)
                'dic(w(0)) = dic(w(0)) & ws.Cells(i, "A").Value & Chr(10)’実際の本文
            End If
        Next

        '下書き作成処理
        For Each k In dic.keys
            '直接送るときは、第１引数をTrueに。（Falseで下書き保存）
            If メール送信(False, CStr(k), "", "タイトル", dic(k)) = 1 Then
                msg = msg & k & ":" & "成功" & Chr(10)
            Else
                msg = msg & k & ":" & "失敗" & Chr(10)
            End If
        Next k
        MsgBox msg
    End Sub

    Function OutLookChk() As Boolean
        'アウトルックのオブジェクトチェック
        'objOLにGetObjectで変数を格納できなければ、On Errorステートメントのエラーになるので
        'エラーを返す
        '回避方法はアウトルックを開いてから実行すること
        Dim objOL As Object
        OutLookChk = True
        On Error Resume Next
            Err.Clear
            Set objOL = GetObject(, "Outlook.Application")
        If Err > 0 Then OutLookChk = False
        Err.Clear
        On Error GoTo 0
        Set objOL = Nothing
    End Function
    Function メール送信(送信 As Boolean, 宛先 As String, CC As String, 件名 As String, 本文 As String, ParamArray 添付()) As Long
        'OutLookの立上げはチェックしていないので、事前にチェックする
        '0 = 失敗　1 = 成功
        'OlBodyFormat 列挙
        Const olFormatHTML = 2        'HTML 形式
        Const olFormatPlain = 1       'テキスト形式
        Const olFormatRichText = 3    'リッチ テキスト形式
        Const olFormatUnspecified = 0 '形式の指定なし
        'CreateItem定数
        Const olMailItem = 0          'メールメッセージ
        Const olAppointmentItem = 1   '予定アイテム
        Dim i As Long
        With CreateObject("Outlook.Application")
            On Error GoTo errHandler
            With .createitem(olMailItem)
                .BodyFormat = olFormatRichText 'とりあえずリッチテキスト形式、HTML等に変更したい場合は、↑の定数から書き換える
                .To = 宛先
                .CC = CC
                .Subject = 件名
                .body = 本文
                If IsMissing(添付) = False Then
                    For i = 0 To UBound(添付)
                        .Attachments.Add 添付(i)
                    Next i
                End If
                If 送信 = True Then
                    .Send    '直接送信箱行き
                Else
                    .Save     '下書き保存
                    '.display '表示
                End If
                メール送信 = 1
            End With
            On Error GoTo 0
        End With
        Exit Function
    errHandler:
    End Function
（稲葉） 2023/05/29(月) 10:16:12

上記についてありがとうございました。
次にうまくいかないことがありましたのでご教授願います。
Private Sub Worksheet_Change(ByVal Target As Range)

    'セルの内容を変更した時
    Dim wProtect    As Boolean
    wProtect = False

    '表示開始日チェック
    If IsDate(Me.Range("表示開始日")) = False Then
        Me.Range("表示開始日") = DateSerial(Year(Date), Month(Date), 1)
    End If

    'カレンダ選択時処理
    If Target.Rows.Count = 1 And Target.Columns.Count = 1 Then  '1セルのみを変更
        '入力規則のリストからの選択
        If Target = "ｶﾚﾝﾀﾞ..." Then
            'カレンダフォームから日付選択
            commParamDate = Date
            frmCalendar.Show vbModal
            Target = rtnDate
        ElseIf Target = "本日.." Then
            '本日日付セット
            Target = Date
        End If
    End If

    '「表示開始日」変更時処理
    If Target.Address = Me.Range("表示開始日").Address Then
        If Me.ProtectContents = True Then   'シート保護時
            wProtect = True
            Me.Unprotect    'シート保護解除
        End If
        Call SetMemory      '日メモリ設定
        Call SetYoteLine    '予定工程線 描画
        Call SetJisekiLine  '実績工程線 描画
        GoTo ExitTrap
    End If

    '工程明細内 変更時処理
    If Target.Row >= CmpTopRow And Target.Row <= CmpEndRow Then
        If Target.Column >= CmpLeftClm And Target.Column <= CmpMemLeftClm - 1 Then
            If Me.ProtectContents = True Then   'シート保護時
                wProtect = True
                'Me.Unprotect    'シート保護解除
            End If
            Call SetYoteLine    '予定工程線 描画
            Call SetJisekiLine  '実績工程線 描画
        End If
    End If
ExitTrap:
    'シート保護
    If wProtect = True Then
        Me.Protect
    End If
'Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rng As Range
    Set rng = Intersect(Target, Range("E:H"))

    If Not rng Is Nothing Then
        Application.EnableEvents = False

        Dim cell As Range
        For Each cell In rng
            Dim rowNum As Long
            rowNum = cell.Row

            If IsDate(Range("E" & rowNum).Value) And IsDate(Range("F" & rowNum).Value) Then
                If Range("G" & rowNum).Value = "" And Range("H" & rowNum).Value = "" Then
                    Range("J" & rowNum).Value = "未実施"
                ElseIf IsDate(Range("G" & rowNum).Value) And Range("H" & rowNum).Value = "" Then
                    Range("J" & rowNum).Value = "実施中"
                ElseIf IsDate(Range("G" & rowNum).Value) And IsDate(Range("H" & rowNum).Value) Then
                    Range("J" & rowNum).Value = "完了"
                End If
            End If

            ' H列の日付が過去の場合、セルの値をクリア
            If cell.Column = 8 And cell.Row > 6 Then
                If IsDate(cell.Value) And cell.Value < Date Then
                    cell.ClearContents
                End If
            End If

            ' K列の値を設定
            If cell.Column = 8 And cell.Row > 6 Then
                If Range("H" & rowNum).Value <> "" And (Range("F" & rowNum).Value = "" Or (Range("F" & rowNum).Value <= Range("H" & rowNum).Value And Range("F" & rowNum).Value <> Range("H" & rowNum).Value)) Then
                    Range("K" & rowNum).Value = "〇"
                Else
                    Range("K" & rowNum).Value = ""
                End If
            End If
        Next cell

        Application.EnableEvents = True
    End If
End Sub
上記のコードは１ヵ月シートに書いているのですが
追加でD列（担当者リスト[設定シートのH4～Ｈ１０に]）７以降にリストの変更があった場合担当に選ばれた人に自動でメール送信したいと考えてます。
Sub CheckChangesAndSendEmail()
    Dim rng As Range
    Dim lastRow As Long
    Dim currentList As String
    Dim previousList As String
    Dim outlookApp As Object
    Dim outlookMail As Object
    Dim addresses As Range
    Dim names As Range
    Dim i As Long

    ' 変更を確認する範囲を指定（Sheet1のセルD7から下）
    Set rng = ThisWorkbook.Sheets("Sheet1").Range("D7")
    lastRow = ThisWorkbook.Sheets("Sheet1").Cells(ThisWorkbook.Sheets("Sheet1").Rows.Count, rng.Column).End(xlDown).Row

    ' 直近の実行時の担当者リストを取得
    previousList = Join(Application.Transpose(ThisWorkbook.Sheets("Sheet1").Range(rng, ThisWorkbook.Sheets("Sheet1").Cells(lastRow, rng.Column)).Value), vbCrLf)

    ' 現在の担当者リストとメールアドレスを取得
    currentList = ""
    Set addresses = ThisWorkbook.Sheets("設定シート").Range("J4:J10") ' メールアドレスが入力されている範囲を指定
    Set names = ThisWorkbook.Sheets("設定シート").Range("H4:H10") ' 担当者名が入力されている範囲を指定
    For i = 7 To lastRow
        currentList = currentList & ThisWorkbook.Sheets("Sheet1").Range("D" & i).Value & vbCrLf
    Next i

    ' 変更があるかどうかを比較
    If currentList <> previousList Then
        ' 変更がある場合はメールを送信
        Set outlookApp = CreateObject("Outlook.Application")

        ' 各担当者ごとにメールを送信
        For i = 1 To addresses.Rows.Count
            If InStr(currentList, names.Cells(i, 1).Value) > 0 Then
                Set outlookMail = outlookApp.CreateItem(0)
                With outlookMail
                    .To = addresses.Cells(i, 1).Value ' メールアドレスを設定
                    .Subject = "担当者リストの変更がありました" ' メールの件名を設定
                    .Body = "担当者リストが変更されました。" & vbCrLf & "変更した担当者名: " & names.Cells(i, 1).Value ' メールの本文を設定
                    .Send ' メールを送信
                End With
                Set outlookMail = Nothing
            End If
        Next i

        Set outlookApp = Nothing
    End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)

    ' 変更があった場合にメールを送信する
    If Not Application.Intersect(Target, Range("D7:D99")) Is Nothing Then
        CheckChangesAndSendEmail
    End If
End Sub
を書いてみたのですがメール送信も受信もできません。
助けてください。
よろしくお願いいたします。

（白ご飯） 2023/05/30(火) 23:29:09

 完全に無視されてるみたいなので、私は降りますね。
（稲葉） 2023/05/31(水) 09:19:28

コメント返信：

[ 一覧(最新更新順) ]

[[20230527191732]] 『Excelでタスク管理を作成しています』（白ご飯） ページの最後に飛ぶ

[[20230527191732]]　『Excelでタスク管理を作成しています』（白ご飯）　ページの最後に飛ぶ