現在、下記のコードでsheetの更新をし保存で閉じた際自動でメール送信をする
マクロで約半年運用しております。
今回、以下の指定した範囲以外を更新した時は「別アドレス」「別メール」を同じ様に
自動送信したいと思っております。※件名、本文も別
(現範囲) S4:S200
(追加範囲)M4:M200
追記可能であればご教授頂ければと思っております。
よろしくお願い致します。
----------------------------------------------------------------------------
Option Explicit
Private SavedFlg As Boolean '//保存の変数
Private ChangeFlg As Boolean '//範囲変更の変数
'標準モジュールに別途「 Public myShFlg() As Boolean 」記述あり
Private Sub Workbook_Open()
Dim i As Long
ReDim myShFlg(1 To ThisWorkbook.Sheets.Count) 'シート数の準備を下記「Workbook_BeforeClose」にする
For i = 1 To ThisWorkbook.Sheets.Count
myShFlg(i) = False '念のために全てFalseをセット
Next i
End Sub
'範囲指定フラグ
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
'If Intersect(Target, Sh.Range("S1")) Is Nothing Then Exit Sub '【メンテナンス用】
If Intersect(Target, Sh.Range("S4:S200")) Is Nothing Then Exit Sub '//指定範囲 日計表処理が「済」
ChangeFlg = True '//範囲外ならMail送信しないフラグ
myShFlg(Sh.Index) = True '//更新されたシートのフラグをTrueに
End Sub
'保存フラグ
Private Sub Workbook_AfterSave(ByVal Success As Boolean)
SavedFlg = True
End Sub
'ファイルを閉じ保存した時に更新シート別にメールを送信
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Const olMailItem = 0
Const olFormatPlain = 1
If Not Saved Then
Select Case MsgBox("'" & ThisWorkbook.Name & "' の変更内容を保存しますか?", vbExclamation + vbYesNoCancel)
Case vbYes
Application.EnableEvents = False
ThisWorkbook.Save
Application.EnableEvents = True
SavedFlg = True
Case vbNo
ThisWorkbook.Saved = True
Case vbCancel
Cancel = True
Exit Sub
End Select
End If
If Not SavedFlg Then Exit Sub
If Not ChangeFlg Then Exit Sub
'//シートごとのアドレス設定_複数Add設定は「;」で区切る。
'myShFlg(〇)はタブ左からのNo.
'sheet1
If myShFlg(1) Then Call myMailSend("メールアドレス", Worksheets(1).Name)
'sheet2
If myShFlg(2) Then Call myMailSend("メールアドレス", Worksheets(2).Name)
'sheet3
If myShFlg(3) Then Call myMailSend("メールアドレス", Worksheets(3).Name)
'実際は24タブあり
Exit Sub
End Sub
続く・・・
No.4ベストアンサー
- 回答日時:
連投すみません
シートごとのフラグをたてる必要がありますね(変数スコープは不明)
判り難くなってしまうかもなので今与えられているコードの添削します
Private SavedFlg As Boolean '//保存の変数
Private ChangeFlg As Boolean '//範囲変更の変数
Private RangeFlg() As Boolean
Private myShFlg() As Boolean
'標準モジュールに別途「 Public myShFlg() As Boolean 」記述あり
Private Sub Workbook_Open()
Dim i As Long
ReDim myShFlg(1 To ThisWorkbook.Sheets.Count) 'シート数の準備を下記「Workbook_BeforeClose」にする
ReDim RangeFlg(1 To ThisWorkbook.Sheets.Count)
For i = 1 To ThisWorkbook.Sheets.Count
myShFlg(i) = False '念のために全てFalseをセット
RangeFlg(i) = False
Next i
End Sub
'範囲指定フラグ
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
'If Intersect(Target, Sh.Range("S1")) Is Nothing Then Exit Sub '【メンテナンス用】
If Intersect(Target, Sh.Range("S4:S200,M4:M200")) Is Nothing Then Exit Sub '//指定範囲 日計表処理が「済」
If Target.Column = 13 Then
RangeFlg(Sh.Index) = True
Else
RangeFlg(Sh.Index) = False
End If
ChangeFlg = True '//範囲外ならMail送信しないフラグ
myShFlg(Sh.Index) = True '//更新されたシートのフラグをTrueに
End Sub
'保存フラグ
Private Sub Workbook_AfterSave(ByVal Success As Boolean)
SavedFlg = True
End Sub
'ファイルを閉じ保存した時に更新シート別にメールを送信
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Const olMailItem = 0
Const olFormatPlain = 1
If Not Saved Then
Select Case MsgBox("'" & ThisWorkbook.Name & "' の変更内容を保存しますか?", vbExclamation + vbYesNoCancel)
Case vbYes
Application.EnableEvents = False
ThisWorkbook.Save
Application.EnableEvents = True
SavedFlg = True
Case vbNo
ThisWorkbook.Saved = True
Case vbCancel
Cancel = True
Exit Sub
End Select
End If
If Not SavedFlg Then Exit Sub
If Not ChangeFlg Then Exit Sub
'//シートごとのアドレス設定_複数Add設定は「;」で区切る。
'myShFlg(〇)はタブ左からのNo.
'M4:M200が変更された場合、RangeFlg=True
Dim myCCAdd() As String
ReDim myCCAdd(24, 1)
'M列アドレス
myCCAdd(1, 0) = "メールアドレス1"
myCCAdd(2, 0) = "メールアドレス2"
myCCAdd(3, 0) = "メールアドレス3"
myCCAdd(4, 0) = "メールアドレス4"
'実際は24タブあり
'S列アドレス
myCCAdd(1, 1) = "メールアドレス1"
myCCAdd(2, 1) = "メールアドレス2"
myCCAdd(3, 1) = "メールアドレス3"
myCCAdd(4, 1) = "メールアドレス4"
'実際は24タブあり
For i = 1 To UBound(myShFlg)
'M列ならば
If RangeFlg(i) Then
If myShFlg(i) Then Call myMailSend(myCCAdd(i, 0), Worksheets(i).Name, RangeFlg(i))
Else
If myShFlg(i) Then Call myMailSend(myCCAdd(i, 1), Worksheets(i).Name, RangeFlg(i))
End If
Next
Exit Sub
End Sub
No.5
- 回答日時:
続き
Sub myMailSend(myToAdd As String, myShName As String, rngFlg As Boolean)
On Error GoTo ErrorHandler
Dim objOutlook As Object
Set objOutlook = CreateObject("Outlook.Application")
Dim myBody As String
If rngFlg Then
'M用メッセージ
myBody = "担当者 様" & vbCrLf & _
"処理が完了致しましたのでお知らせ致します。" & vbCrLf & _
"ご確認下さい。"
Else
'S用メッセージ
myBody = "担当者 様" & vbCrLf & _
"処理が完了致しましたのでお知らせ致します。" & vbCrLf & _
"ご確認下さい。"
End If
With objOutlook.CreateItem(olMailItem)
.To = myToAdd
.CC = "メールアドレス"
.BCC = ""
.Subject = "【" & myShName & "】 " & "更新のお知らせ(自動送信)"
.Body = myBody
.BodyFormat = olFormatPlain '//テキストメール指定
.Send
End With
Finally:
Set objOutlook = Nothing
Exit Sub
ErrorHandler:
MsgBox "メールの送信に失敗しました。", vbOKOnly + vbCritical
Resume Finally
End Sub
No.3
- 回答日時:
続き
④メール作成プロシージャ 引数を増やしBody文字列を作成
Sub myMailSend(myToAdd As String, myShName As String, rngFlg As Boolean)
On Error GoTo ErrorHandler
Dim objOutlook As Object
Set objOutlook = CreateObject("Outlook.Application")
Dim myBody As String
If rngFlg Then
'M用メッセージ
myBody = "担当者 様" & vbCrLf & _
"処理が完了致しましたのでお知らせ致します。" & vbCrLf & _
"ご確認下さい。"
Else
'S用メッセージ
myBody = "担当者 様" & vbCrLf & _
"処理が完了致しましたのでお知らせ致します。" & vbCrLf & _
"ご確認下さい。"
End If
With objOutlook.CreateItem(olMailItem)
.To = myToAdd
.CC = "メールアドレス"
.BCC = ""
.Subject = "【" & myShName & "】 " & "更新のお知らせ(自動送信)"
.Body = myBody
.BodyFormat = olFormatPlain '//テキストメール指定
.Send
End With
.Subjectも変更したいようですが、内容がわからないので
.Body = myBodyを参考に変更すれば容易と思われます
もっと複雑な条件、内容が必要な場合はシートのセルを使ったり
Select Caseで条件分岐して必要なアドレス、件名、本文を文字列として作成するのが良いと思います
以上4か所ですが、想像の範疇もありますがどうでしょう
No.2
- 回答日時:
やはり文章では無理か‥
#1の内容をコードにしてみました
>'標準モジュールに別途 など不明な処理があるので上手くいくかは分かりませんが、M4:M200を追加して その時にメールの内容を変える
出来るだけ既存コードの変更をしない・・・と下記の箇所を書き換えてみてください(必ずコピーファイルでテストしてください)
記載モジュールを変更する必要はないと思います
追加場所は、重複するコードで判断してください
①1行のみ追加
Option Explicit
Private SavedFlg As Boolean '//保存の変数
Private ChangeFlg As Boolean '//範囲変更の変数
Private RangeFlg As Boolean '//範囲のカラム位置を判定する変数
'標準モジュールに別途「 Public myShFlg() As Boolean 」記述あり
② ,M4:M200 If Target.Column = 13 Then RangeFlg = True 追加
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
'If Intersect(Target, Sh.Range("S1")) Is Nothing Then Exit Sub '【メンテナンス用】
If Intersect(Target, Sh.Range("S4:S200,M4:M200")) Is Nothing Then Exit Sub '//指定範囲 日計表処理が「済」
If Target.Column = 13 Then RangeFlg = True
ChangeFlg = True '//範囲外ならMail送信しないフラグ
③ アドレス設定、範囲フラグを追加
(多分、もっとシンプルだと思いますが)
//シートごとのアドレス設定_複数Add設定は「;」で区切る。
'myShFlg(〇)はタブ左からのNo.
'M4:M200が変更された場合、RangeFlg=True
If RangeFlg Then
'M列ならば
'sheet1
If myShFlg(1) Then Call myMailSend("メールアドレス1", Worksheets(1).Name, RangeFlg)
'sheet2
If myShFlg(2) Then Call myMailSend("メールアドレス1", Worksheets(2).Name, RangeFlg)
'sheet3
If myShFlg(3) Then Call myMailSend("メールアドレス1", Worksheets(3).Name, RangeFlg)
'実際は24タブあり
Else
'S列ならば
'sheet1
If myShFlg(1) Then Call myMailSend("メールアドレス", Worksheets(1).Name, RangeFlg)
'sheet2
If myShFlg(2) Then Call myMailSend("メールアドレス", Worksheets(2).Name, RangeFlg)
'sheet3
If myShFlg(3) Then Call myMailSend("メールアドレス", Worksheets(3).Name, RangeFlg)
'実際は24タブあり
End If
文字数制限の為、続く
理解不足の為、大変お手数お掛け致しました。
少しカスタマイズさせて頂き、無事作動を確認致しました。
本当にありがとうございました。
No.1
- 回答日時:
こんにちは
ご質問を理解していなかったらスルーしてください
>以下の指定した範囲以外を更新した時
(現範囲) S4:S200
(追加範囲)M4:M200
でフラグをたてるのであれば、Workbook_SheetChangeイベントを変更すれば良いと思います
'範囲指定フラグ
If Intersect(Target, Sh.Range("S4:S200,M4:M200")) Is Nothing Then Exit Sub '//指定範囲 日計表処理が「済」
とすれば実行範囲を広げられます
シートの振り分けについては Sh.Index で設定しているようですので
Select Case Sh.Index とか・・If Sh.Indexとかで フラグ設定すれば良さそうですね
シート振り分け、範囲振り分けはどちらを先にするかは、考察してください
(シート又は範囲振り分け時に下記のフラグ設定も可能)
メールアドレス、本文については
現状 myMailSendの引数でメールアドレス、件名を設定しているようですね
'sheet1
If myShFlg(1) Then Call myMailSend("メールアドレス", Worksheets(1).Name)
やり方は色々あると思いますが
引き数を増やして(メールアドレス、件名、本文またはフラグ)にして条件や新たなフラグ設定などで振り分けるとかですかね
文章の説明なので上手く伝わりますでしょうかね?
ご回答ありがとうございます。
質問が伝わりにくかったようで申し訳ございません。
範囲のS4:S400 は現行のマクロ
範囲のM4:M400 の更新は別アドレス宛(件名・本文も別設定)
ド素人の為、なるべく現在のマクロをいじりたくなく、追加(多少の変更)で対処したいのです。
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
似たような質問が見つかりました
- Visual Basic(VBA) 【変更】ファイルを閉じてダイアログで保存した時、更新したシートだけの処理の実行をする 5 2022/03/26 18:31
- Visual Basic(VBA) 【追加】ファイルを閉じてダイアログで保存した時だけ処理の実行をする 3 2022/03/23 15:43
- Excel(エクセル) 2つのVBAを一緒にしたら機能しなくなりました(エクセル) 7 2022/06/02 12:41
- Excel(エクセル) VBAについて 3 2022/06/19 18:19
- Excel(エクセル) エクセルVBAでオブジェクトが必要です 2 2022/09/10 16:37
- Visual Basic(VBA) 【VBA】写真の貼り付けコードがうまく機能しません。 5 2022/09/01 18:43
- Visual Basic(VBA) VBAのユーザーフォームのテキストボックスに入力制限をしたい 6 2022/11/15 08:28
- Visual Basic(VBA) excel vbaでvlooupの変数がわかりません。 7 2022/05/30 09:35
- Visual Basic(VBA) エクセルのVBAでダブルクリックでチェックを入れたあと 1 2022/10/26 20:30
- Visual Basic(VBA) Excel vbaについての質問 3 2023/04/18 16:14
このQ&Aを見た人はこんなQ&Aも見ています
関連するカテゴリからQ&Aを探す
おすすめ情報
このQ&Aを見た人がよく見るQ&A
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
マクロの「SaveAs」でエラーが...
-
VBA 空白行に転記する
-
100万件越えCSVから条件を満た...
-
EXCELのSheet番号って変更でき...
-
マクロ実行後に別シートの残像...
-
Count Ifのセルの範囲指定に変...
-
グラフマクロで系列を変数にす...
-
Unionでの他のシートの参照につ...
-
楽天RSSからエクセルVBAを使用...
-
Changeイベントで複数セルへの...
-
VBA 最終行を選んだシートにコ...
-
VBAで質問ですが、皆さんはどの...
-
複数シートの複数列に入力され...
-
VB2005でExcelのグラフのデータ...
-
【VBA】データを各シートに自動...
-
Excel2013で切り取り禁止
-
VBA 実行時エラー1004 rangeメ...
-
RemoveDuplicatesメソッドにつ...
-
VBAでEXCELから固定長...
-
VBA シリアル値から月日への変換
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
マクロの「SaveAs」でエラーが...
-
VBA 空白行に転記する
-
EXCELのSheet番号って変更でき...
-
マクロ実行後に別シートの残像...
-
VBA 別ブックからの転記の高速...
-
VBA別シートの最終行の次行へ転...
-
【VBA】特定の条件でセルをコピー
-
Count Ifのセルの範囲指定に変...
-
100万件越えCSVから条件を満た...
-
楽天RSSからエクセルVBAを使用...
-
VBAコードについて
-
Changeイベントで複数セルへの...
-
VBAで変数の数/変数名を動的に...
-
Excel2013で切り取り禁止
-
グラフマクロで系列を変数にす...
-
VBA 実行時エラー1004 rangeメ...
-
ExcelのVBマクロを、バックグラ...
-
Unionでの他のシートの参照につ...
-
Excel VBA オートフィルターで...
-
アクセスからエクセルへ出力時...
おすすめ情報
'ファイルを閉じ保存した時更新シート別にメールを送信
Sub myMailSend(myToAdd As String, myShName As String)
On Error GoTo ErrorHandler
Dim objOutlook As Object
Set objOutlook = CreateObject("Outlook.Application")
続く・・・
With objOutlook.CreateItem(olMailItem)
.To = myToAdd
.CC = "メールアドレス"
.BCC = ""
.Subject = "【" & myShName & "】 " & "更新のお知らせ(自動送信)"
.Body = "担当者 様" & vbCrLf & _
"処理が完了致しましたのでお知らせ致します。" & vbCrLf & _
"ご確認下さい。"
.BodyFormat = olFormatPlain '//テキストメール指定
.Send
End With
Finally:
Set objOutlook = Nothing
Exit Sub
ErrorHandler:
MsgBox "メールの送信に失敗しました。", vbOKOnly + vbCritical
Resume Finally
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
長くなりましたが以上です。
よろしくお願いいたします。