Results of 1 - 1 of about 37696 for IF (0.008 sec.)
- [[20230527191732]]
- #score: 1591
- @digest: 22929764d267f96efb3cd2a3bf958179
- @id: 94346
- @mdate: 2023-05-31T00:19:28Z
- @size: 13488
- @type: text/plain
- #keywords: outlookmail (52054), outlookapp (45246), rownum (40620), currentlist (39289), wprotect (37491), outlookchk (28021), addresses (26533), 程線 (24234), 示開 (24159), 線描 (20194), 者リ (12054), 送信 (10455), ル送 (10122), 下書 (9738), createitem (8317), outlook (8143), 本文 (5890), ヵ月 (5603), メー (4941), 当者 (4534), isdate (4256), を送 (4079), 担当 (3962), タス (3728), ト保 (3181), 始日 (3114), 工程 (3046), 描画 (2779), lastrow (2679), 添付 (2446), cell (2346), ール (2237)
- 『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 ＞ ---- できるかできないかで言えばできます。 ぱっと思い浮かぶ方法は 1.ExcelからOutlookを起動してOutlookでメールを送る。 2.CDOを使ってメールを送る。 3.BASP21などのdllを使ってメールを送る。 の3つです。 1 ⇒ 外部のナニカを使用することなくVBAだけで完結でき、メールサーバー側の制約も少ないが、ちょっと不便。 2 ⇒ Microsoftの標準的な機能で完結できるが、メールサーバー側の制約がある。 3 ⇒ 使いやすいものが多いが、外部のナニカを使うことになる。 です。 （高橋） 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 '直接送るときは、第1引数を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 上記のコードは1ヵ月シートに書いているのですが 追加でD列（担当者リスト[設定シートのH4〜H10に]）7以降にリストの変更があった場合担当に選ばれた人に自動でメール送信したいと考えてます。 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... - https://www.excel.studio-kazu.jp/wiki/kazuwiki/202305/20230527191732.txt - [detail] - similar
PREV
NEXT
Powered by Hyper Estraier 1.4.13, with 97055 documents and 608280 words.
訪問者：