助けて頂いた「ファイルを閉じてダイアログで保存した時だけ処理の実行をする」をメール送信する運用しております。
すべてうまく行っていると思いましたが、5つあるsheetの中で関係ないSheetで更新があった時でもメールが配信される為、更新の多い時がありクレームがありました。
Private Sub Workbook_〇〇をWorksheet_○○に変えればよいのでしょうか?
ThisWorkbookからSheet1,2・・に書き写せば良いかと思いましたが無理でした。
Sheetごとの「Sheet○が更新し閉じた時~」にする事は可能でしょうか?
よろしくお願いいたします。
Option Explicit
Private SavedFlg As Boolean
Private ChangeFlg As Boolean
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Intersect(Target, Sh.Range("A1:A100")) Is Nothing Then Exit Sub
ChangeFlg = 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 ChangeFlg Then Exit Sub
If Not SavedFlg Then Exit Sub
<以下略>
No.5ベストアンサー
- 回答日時:
こんばんは。
下記でも、エラーになるでしょうか?
'★標準モジュールに記載
Public myShFlg() As Boolean ' 動的配列を用意
'★Thisworkbookに下記を記載
Option Explicit
Private SavedFlg As Boolean
Private ChangeFlg As Boolean
’
Private Sub Workbook_Open()
Dim I As Long
ReDim myShFlg(1 To ThisWorkbook.Sheets.Count) 'シート数準備
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("B2:J10")) Is Nothing Then Exit Sub
ChangeFlg = True
myShFlg(Sh.Index) = True '更新されたシートのフラグをTrueに '←★エラーになります
If Application.Intersect(Target, Sh.Range("A2:J10")) Is Nothing Then
Exit Sub
End Sub
'保存
Private Sub Workbook_AfterSave(ByVal Success As Boolean)
SavedFlg = True
End Sub
以下、Workbook_BeforeCloseとSub myMailSend
mygoonickname 様
ご対応ありがとうございました!
myShNameでの文字列を付加する事が出来き
すべて思う通りの作動を無事に確認いたしました。
この度は何度もお付き合い、遅くまでありがとうございました。
感謝致します。
No.4
- 回答日時:
No.1の者です。
すみません、下記修正になります。 myMailSendが抜けていました。
If myShFlag(1) Then Call("test@1",worksheets(1).Name)
↓
If myShFlag(1) Then Call myMailSend("test@1",worksheets(1).Name)
>myShFlg(○…)○の部分をsheet2だと2ということでしょうか?
→ブックを表示した時に、一番左にあるシートが1、右隣が2ですね。
>.Subject = myShName ←★Sheet名付加【sheet○】
>シート名だけになりませんか?
→シート名だけだと思いますが。。。
Call myMailSend("test@1",worksheets(1).Name) で読んで、
Sub myMailSend(myToAdd As String,myShName As String)
が呼ばれる。 処理がこちらに移ります。 その際、
myToAddには、"test@1"が入ります。
myShNameには、worksheets(1).Name:シート名が入ります。
以下の通り修正しましたが数カ所保存時、起動時にエラーがあります。
★のところは確認、エラーが出る場所です。
-------------------
Public myShFlg() As Boolean ' 動的配列を用意 '←★標準モジュールに記載
Option Explicit
Private SavedFlg As Boolean
Private ChangeFlg As Boolean
Private Sub Workbook_Open()
Dim I As Long
ReDim myShFlg(1 To ThisWorkbook.Sheets.Count) 'シート数準備
ReDim myShFlg(2 To ThisWorkbook.Sheets.Count) '←★シート2・3の場合はこれでOK?
ReDim myShFlg(3 To ThisWorkbook.Sheets.Count) '←★シート2・3の場合はこれでOK?
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("B2:J10")) Is Nothing Then Exit Sub
ChangeFlg = True
myShFlg(Sh.Index) = True '更新されたシートのフラグをTrueに '←★エラーになります
If Application.Intersect(Target, Sh.Range("A2:J10")) Is Nothing Then
Exit Sub
End Sub
'保存
Private Sub Workbook_AfterSave(ByVal Success As Boolean)
SavedFlg = True
End Sub
以下、Workbook_BeforeCloseとSub myMailSend
No.3
- 回答日時:
No.1の者です。
シートが2枚変更があったら、メールを2通送信するで良いでしょうか?
イメージ的には、下記の様な感じでどうでしょうか?
手入力ですので、エラーが出たら、修正して下さい。
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Const olMailItem = 0
Const olFormatPlain = 1
'途中省略
If Not ChangeFlg Then Exit Sub
If Not SavedFlg Then Exit Sub
If myShFlag(1) Then Call("test@1",worksheets(1).Name)
If myShFlag(2) Then Call("test@2",worksheets(2).Name)
If myShFlag(3) Then Call("test@3",worksheets(3).Name)
'必要に応じて、45と追加。
Exit sub
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 ←★Sheet名付加【sheet○】
.Body = "このメールはシートの更新テストメールです"
.BodyFormat = olFormatPlain
'途中省略
Resume Finally
End Sub
ご回答ありがとうございます。
ReDim myShFlg(1 To ThisWorkbook.Sheets.Count) 'シート数準備
→myShFlg(○…)○の部分をsheet2だと2ということでしょうか?
If myShFlag(1) Then Call("test@1",worksheets(1).Name)
If myShFlag(2) Then Call("test@2",worksheets(2).Name)
If myShFlag(3) Then Call("test@3",worksheets(3).Name)
上記で入力するとコンパイルエラーで赤くなります。
.Subject = myShName ←★Sheet名付加【sheet○】
→シート名だけになりませんか?
申し訳ございません。よろしくお願いいたします。
No.2
- 回答日時:
No.1の者です。
???
シート毎でしたら、配列を用意して、どのシートが更新されたかをフラグに
入れておいて、後ほどそのフラグをチェックするでしょうか?
'標準モジュールに下記を記載
Public myShFlg() As Boolean ' 動的配列を用意
'Thisworkbookに、下記を記載
Private Sub Workbook_Open()
Dim I As Long
ReDim myShFlg(1 To ThisWorkbook.Sheets.Count) 'シート数準備
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("A1:A100")) Is Nothing Then Exit Sub
myShFlg(Sh.Index) = True '更新されたシートのフラグをTrueに
End Sub
'処理する部分で、フラグで判定して処理する
If myShFlag(1) Then 'シート1が更新、処理~
If myShFlag(2) Then 'シート2が更新、処理~
If myShFlag(3) Then 'シート3が更新、処理~
ご回答ありがとうございます。
以下は、
閉じた(保存)後の処理はこんなイメージでした。
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 ChangeFlg Then Exit Sub
If Not SavedFlg Then Exit Sub
On Error GoTo ErrorHandler
Dim objOutlook As Object
Set objOutlook = CreateObject("Outlook.Application")
With objOutlook.CreateItem(olMailItem)
.To = "test@" ←★ここをシート毎に変える
.CC = ""
.BCC = ""
.Subject = "【テスト】自動送信" ←★Sheet名付加【sheet○】
.Body = "このメールはシートの更新テストメールです"
.BodyFormat = olFormatPlain
.Send
End With
Finally:
Set objOutlook = Nothing
Exit Sub
ErrorHandler:
MsgBox "メールの送信に失敗しました", vbOKOnly + vbCritical
Resume Finally
End Sub
No.1
- 回答日時:
こんばんは。
例えば、対象シートの名前が決まっているなら、シート名で判定すれば、
対象シートを絞れるかと。
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Intersect(Target, Sh.Range("A1:A100")) Is Nothing Then Exit Sub
If Sh.Name = 〇〇 or Sh.Name = △△ Then ChangeFlg = True
End Sub
若しくは、配列を用意し、どのシートが変更されたかを、Sh.Indexなどで
取得しておいて、変更のあったシートだけを処理するとかでしょうか?
ご回答ありがとうございます。
Sheetごとに設定したメルアドに配信したいと思っております。
このシートは誰々さんにとか・・・
以下はOutlookからの処理があります。
On Error GoTo ErrorHandler
Dim objOutlook As Object
Set objOutlook = CreateObject("Outlook.Application")
With objOutlook.CreateItem(olMailItem)
.To = "test@"
On Error GoTo ErrorHandler
Dim objOutlook As Object
Set objOutlook = CreateObject("Outlook.Application")
With objOutlook.CreateItem(olMailItem)
.To = "test@"
.CC = ""
.BCC = ""
.Subject = "【テスト】自動送信"
.Body = "このメールは自動テストメールです"
.BodyFormat = olFormatPlain
.Send
End With
Finally:
Set objOutlook = Nothing
Exit Sub
ErrorHandler:
MsgBox "メールの送信に失敗しました", vbOKOnly + vbCritical
Resume Finally
End Sub
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
似たような質問が見つかりました
- Visual Basic(VBA) 【Excel VBA】自動メール送信の機能追加 5 2022/09/29 12:53
- Visual Basic(VBA) 【追加】ファイルを閉じてダイアログで保存した時だけ処理の実行をする 3 2022/03/23 15:43
- Excel(エクセル) 2つのVBAを一緒にしたら機能しなくなりました(エクセル) 7 2022/06/02 12:41
- Visual Basic(VBA) エクセルのVBAでダブルクリックでチェックを入れたあと 1 2022/10/26 20:30
- Excel(エクセル) VBAについて 3 2022/06/19 18:19
- Visual Basic(VBA) 【VBA】写真の貼り付けコードがうまく機能しません。 5 2022/09/01 18:43
- Visual Basic(VBA) VBAのユーザーフォームのテキストボックスに入力制限をしたい 6 2022/11/15 08:28
- Visual Basic(VBA) エクセル VBAについて 2 2022/05/16 16:33
- Excel(エクセル) エクセルVBAでオブジェクトが必要です 2 2022/09/10 16:37
- Excel(エクセル) Excel2019 マクロを使用し画像を貼り付けした際のリンク切れについて 2 2022/11/15 16:14
関連するカテゴリからQ&Aを探す
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
【ExcelVBA】全シートのセルの...
-
別のシートから値を取得するとき
-
特定の文字を含むシートだけマ...
-
【VBA】シート名に特定文字が入...
-
XL:BeforeDoubleClickが動かない
-
excelのマクロで該当処理できな...
-
ユーザーフォームに入力したデ...
-
エクセルのシート名変更で重複...
-
シートが保護されている状態で...
-
ExcelのVBAのマクロで他のシー...
-
同じ作業を複数のシートに実行...
-
VBA 入力月で該当シートを選択...
-
【VBA】色のついたシート名を取得
-
【VBA】指定した検索条件に一致...
-
Excelマクロのエラーを解決した...
-
エクセルで通し番号を入れてチ...
-
VBAで同じシート名のコピー時は...
-
エクセルVBAでダブルクリックを...
-
ブック名、シート名を他のモジ...
-
エクセルのマクロでアクティブ...
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
別のシートから値を取得するとき
-
VBAで大量のファイルをシート名...
-
ユーザーフォームに入力したデ...
-
excelのマクロで該当処理できな...
-
【ExcelVBA】全シートのセルの...
-
同じ作業を複数のシートに実行...
-
VBA 存在しないシートを選...
-
Excelマクロのエラーを解決した...
-
特定の文字を含むシートだけマ...
-
実行時エラー'1004': WorkSheet...
-
XL:BeforeDoubleClickが動かない
-
シートが保護されている状態で...
-
実行時エラー1004「Select メソ...
-
【Excel VBA】Worksheets().Act...
-
ブック名、シート名を他のモジ...
-
エクセルのシート名変更で重複...
-
ExcelのVBAのマクロで他のシー...
-
Excel VBA 複数行を数の分だけ...
-
エクセルのマクロについて教え...
-
VBA 最終行まで数式をコピーする
おすすめ情報