• ベストアンサー

VBAでイベント処理に複数回入ってしまうのを防ぎたい

こんにちは。 マクロのエクセルファイルを操作し、セーブ時にCSV形式でテクストファイルに書くことを実現しようと思っています。 VBAでイベント処理"BeforeSave"で以下のように書くと、初めに書かれた"test.txt"が同じ処理を行おうとしているようで、そこでも書き込みの処理を行おうとする→無限に書き込みが発生?→エラーの表示が出てきます。これはどういう風に対処すればよろしいのでしょうか? Workbook/BeforeSaveイベント処理: Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) Dim file_curr As String Dim msg As String file_curr = ThisWorkbook.Path & "\test.txt" If Dir(file_curr) = "" Then ActiveWorkbook.SaveAs _ Filename:=file_curr, _ FileFormat:=xlCSV, Local:=True msg = "saved" Else msg = "file exist, not saved" End If MsgBox msg End Sub

質問者が選んだベストアンサー

  • ベストアンサー
  • Wendy02
  • ベストアンサー率57% (3570/6232)
回答No.2

>、.xlsmから.txtを記録するとともに 今は、Excel 2007 では試していません。本来、別ファイルの保存のためなら、Application.EnableEvents = False は、必要ないはずです。以下は、プロシージャを二つに分ける必要はないけれども、加工しやすさのために分けました。 '------------------------------------------- Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)   Dim dir_Curr As String   Dim file_Curr As String   Dim flg As Boolean   dir_Curr = ThisWorkbook.Path   file_Curr = dir_Curr & "\test.txt"   On Error GoTo ErrHandler    If Dir(file_Curr) = "" Then     Call CSVFileSaving(file_Curr)     flg = True    End If ErrHandler:   If Err.Number > 0 Then     MsgBox Err.Number & ": " & Err.Description   ElseIf flg Then     MsgBox "Saved safely", vbInformation   Else     MsgBox "Cancelled saving", vbExclamation   End If End Sub Sub CSVFileSaving(fileName As String)  ActiveSheet.Copy  With ActiveWorkbook    .SaveAs fileName:=fileName, FileFormat:=xlCSV, Local:=True ' 'xlTextWindows    .Close False  End With End Sub

maruyl
質問者

お礼

Wendy02さま。 美しくやりたいことが実現できました。また、勉強になりました。御礼申し上げます。

その他の回答 (1)

  • keithin
  • ベストアンサー率66% (5278/7940)
回答No.1

イベントの連鎖は,イベントの中で行おうとしている保存(saveas)の動作がまたイベントをトリガすることで発生します。 もう一つの見落としは,before_saveイベントは「保存する前に起動するアクション」です。つまり無事イベントプロシジャを抜けると,今度は本来の「本番の保存の動作」が続いて起こります。 従って対処として, 1.まず少なくとも cancel = true を忘れず書いて,「本番の保存」はキャンセルする 2.イベント内部でのトリガアクションに先立って,イベントを起動させないよう抑制する private sub workbook_beforesave(…  dim …  (中略)  application.enableevents = false  activeworkbook.saveas 何某  application.enableevents = true  (後略) end sub 若しくは 3.イベントの中で「保存しない」で,何か別の対処を探る?

maruyl
質問者

補足

keithinさま。 ありがとうございます。 1番と2番の方針をとって全ては解決…のように見えました。 しかし、.xlsmから.txtを記録するとともに、普通に.xlsmファイルも セーブしたかったので、Cancel = Trueをコメントアウトすると、同じく連鎖が出てしまいました。 イベント内部でのトリガーアクションはおさえたので、「本番の保存」も一度きりのはずなのに、なぜ連鎖が出るのでしょうか?対処方法をご教授いただけると幸いです。 Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) Dim dir_curr As String Dim file_curr As String Dim msg As String dir_curr = ThisWorkbook.Path file_curr = ThisWorkbook.Path & "\test.txt" ' Cancel = True ' ←これを実行すると問題ないのですが… Application.EnableEvents = False ActiveWorkbook.SaveAs _ Filename:=file_curr, _ FileFormat:=xlCSV, Local:=True Application.EnableEvents = True msg = "saved" MsgBox msg End Sub

関連するQ&A

  • VBAでWorkbook_BeforeSaveイベントで質問

    Workbook_BeforeSaveイベントである条件に達していればExcelファイルを終了したくないのですがどうすればよいでしょうか? WindowsXP ProSP2、Excel2000 コード例) Option Explicit Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) dim flg as boolean if flg=true then exit sub end if End Sub

  • EXCEL VBA Workbook_BeforeSaveについて

    教えて下さい! 会社のホームページにある情報を公開していて、その中に更新時間も載せております。その公開している文章はEXCELを利用しHTMファイルで保存しております。ファイルは社内の共有ファイルサーバーに保存されており、複数にて共有しています。そのEXCEL HTMファイルを編集し、(上書き)保存をした際、その時の時間を更新日時としてあるセルに表示させております。自身でVBAを以下の組みました。 (保存前処理の他、開いた時の列幅処理+前回更新日時の表示も行っています) Option Explicit --------------------------------------------------------- Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) Dim KOUSHINBI As Date KOUSHINBI = Now Range("E2").Value = KOUSHINBI End Sub --------------------------------------------------------------- Private Sub Workbook_Open() MSGDISP '前回更新時間の表示 Dim TODAY As Date, KOUSHIN As Date KOUSHIN = DateValue(Range("E2").Value) TODAY = Date If KOUSHIN <> TODAY Then Columns("B:D").ColumnWidth = 0 End If End Sub -------------------------------------------------------- '以下標準モジュールで Sub MSGDISP() Dim A As Date A = Worksheets("DAILY").Range("E2").Value MsgBox ("前回の更新日時は" & A & "です") End Sub --------------------------------------------- もちろん、 Workbook_BeforeSaveと Workbook_Openは「THIS WORKBOOK」モジュールに記載しております。 これを実行すると、BOOK OPENの処理は行われるのですが、保存時の更新日時の処理が全く起きてくれません。 新規でEXCELを作成し、Workbook_BeforeSaveのみの処理を記述すると上手く処理が行われます。何が原因なのでしょうか??

  • Excelでシート名と最終更新日を自動表示したい

    Excelを使って (1)セルA1に入れた名目をシート名にし (2)セルH1には、最終更新日を自動で入れたいです。 調べた結果、 シート名を右クリックして「コードの表示」から (1)は Private Sub Worksheet_Change(ByVal Target As Range) Sheets(1).Name = Range("B1") End Sub を入れてうまくいきましたが、 (2)は Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)  If ThisWorkbook.Saved = False Then   Worksheets("Sheet1").Range("H1").Value = Date  End If End Sub を入れてみましたが(←調べましたもの) うまくいきませんでした。 単純に、 Private Sub Worksheet_Change(ByVal Target As Range) Sheets(1).Name = Range("B1") End Sub Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)  If ThisWorkbook.Saved = False Then   Worksheets("Sheet1").Range("H1").Value = Date  End If End Sub とつなげて入れるのではだめなんでしょうか? それとも、(2)の何かが間違っていますか? ご教授願います。

  • エクセルVBA イベントプロシージャに引数を渡せま

    お世話になります。 エクセル2003/XP 使用です。 イベントプロシージャに引数を渡せまるかどうか教えていただけますでしょうか? 下記のコード中の変数mysheetnameを ユーザーフォーム、→ CommandButton1のプロシージャに 引数として渡して行きたいのですが、 実行すると、一番最初のWorkbook_SheetBeforeRightClickの時点で、 コンパイルエラー:  プロシージャの宣言が、イベントまたはプロシージャの定義と一致していません。 とエラー表示されます。 イベントプロシージャに引数を渡すことはできますでしょうか? ---------- ThisWorkBook内 ---------- Public mysheetname As String Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean) mysheetname = ActiveSheet.Name UserForm1.Show (mysheetname)     '←変数mysheetnameの値をユーザーフォームに渡したい。 End Sub ---------- ユーザーフォーム ---------- Private Sub UserForm_Initialize(ByVal mysheetname As String ) 処理 End Sub Private Sub CommandButton1_Click(ByVal mysheetname As String ) 処理 End Sub ’--------- ここまで 引数について少し理解し始めたばかりの者です。 よろしくお願いします。

  • エクセルVBAにて保存するとき

    Private Sub Workbook_BeforeClose(Cancel As Boolean) If MsgBox("エクセルを終了してもよろしいですか?", vbYesNo) = vbNo Then Cancel = True Exit Sub End If Application.DisplayAlerts = False Application.Quit End Sub Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) MsgBox "そのボタンでは保存できません。" & vbCrLf & _ "雛形は残しておきましょう" & vbCrLf & _ "" & vbCrLf & _ "ツールバーの「マクロなし出力」から保存できます。" Cancel = True End Sub という二つのマクロをThisworkbookにいれてあるんですが、 この二つを有効(今は2つ目を'でコメント状態にしてあるので保存可)にすると保存できなくて困っています。 二つを有効にした時はどのようにほぞんすればいいですか?

  • Excel VBAでのSaveCopyAsの挙動

    Excel 2016/2019を使っています。よろしくお願いします。 ブックに変更があった場合にバックアップを保存したいので、 上書きにならないように日付と連番をつけてバックアップ専用フォルダにSaveCopyAsを使って保存しようとしています。 明示的に「保存」アイコンをクリックすると期待通りの動作が行われます。しかし、保存せずに「x」印をクリックして閉じてしまった場合でも、変更があるならバックアップファイルを作りたいのですが、SaveCopyAsを通っているのにバックアップファイルが作成されません。 記載したコードは以下のとおりです。 ThisWorkbookオブジェクトに対して、 Public Sub Workbook_beforeClose(Cancel As Boolean) '変更があれば(ThisWorkBookを)保存 If ThisWorkBook.Saved = False Then ThisWorkBook.Save End If End Sub 'ThisWorkBookの保存時にバックアップを作成 Private Sub Workbook_BeforeSave(省略) If ThisWorkbook.Saved = False Then 'バックアップファイルのフルパスを作成  ThisWorkbook.SaveCopyAs "バックアップファイルフルパス" End Sub 何かヒントをお持ちの方みえられましたらご教示いただければ幸いです。

  • VBAの繰りかえし処理について

    workbook1(以下wb1)のB3に入力した県名を含む行を、 workbook2から取り出し、wb1のB7以降に表示させたいと思っています (ちなみに県名はwb2のC列に入っています) 同じ県名が含まれる行が多いので、それらを繰り返し処理で 全て書き出したいと思い、以下のマクロを作りました。 Sub macro3() Dim c Dim wb1 As Workbook Dim wb2 As Workbook Dim k As Integer Dim firstAddress As String Application.ScreenUpdating = False Set wb1 = ActiveWorkbook Set wb2 = Workbooks.Open("G:\zyouhousyori\inn100best_full.csv") Set c = cell.Find(What:=Range("B3").Value) With wb2.Worksheets(1).Range("A1:A100") If Not c Is Nothing Then firstAddress = c.Address Do Set c = cell.FindNext(c) For k = 0 To 10 .Range("C100").End(xlUp).Offset(1).Copy _ wb1.Worksheets("sheet1").Cells(7 + k, 2) Exit For ★Loop While Not c Is Nothing And _ c.Address <> firstAddress End If End With Application.ScreenUpdating = True wb2.Close False End Sub しかし、実行すると★マークのついた所でエラーになってしまいます (対応するDoがありません、と出ます) VBA初心者なので、どこがどう違うのかいまいちわかりません; アドバイスお願いします。

  • Excel VBA 違うxlsファイルの指定したシートを開く処理

    Excel VBAで違うExcelファイルの指定したシートを開きたいのですが、 うまくいきません。現在のコードは、 *フォーム* Private Sub CB1_Click() Dim A As Integer A = MsgBox("データ展開する?", 4, "データ展開?") If A = 6 Then INPORT.FILE_OPEN1 End If End Sub *INPORTモジュール* Sub FILE_OPEN1()  FILE_OPEN8 End Sub Sub FILE_OPEN8() Dim fnames As String fnames = fnames1 Workbooks.Open Filename:=fnames ***ここでしょうか?.Sheet("")と指定しても出来ません*** End Sub Function fnames1() As Variant fnames1 = Application.GetOpenFilename( _ Title:="ファイルを開く", _ FILEFILTER:="エクセルファイル (*.xls), *.xls") If fnames1 = False Then MsgBox ("ファイルを開けませんでした。" & Chr$(13) & _ "もう一度やり直して下さい。") End End If End Function また、指定する事が出来たら、選択したシートを現在のブックにコピーもしたいのですが、どの様にすればよいでしょうか? よろしくお願いします。

  • エクセルのVBAに関する質問です。

    エクセルのVBAに関する質問です。 「指定フォルダ(ここではXXXX)内の全てのエクセルファイルを開き、内容を転記していく」 というマクロについての質問です。 ネットを参照し、以下のマクロを見つけました。 -------------------------------------------------------------------------- Sub Macro1() Dim theName As String Dim theDir As String Dim theBook As Workbook Dim flg As Boolean flg = True Application.ScreenUpdating = False theDir = ThisWorkbook.Path & "\XXXX" theName = Dir(theDir & "\*.xls") Do While theName <> "" Set theBook = Workbooks.Open(theDir & "\" & theName) Call subA(theBook, flg) flg = False theBook.Close theName = Dir Loop End Sub Sub subA(theBook As Workbook, flg As Boolean) Dim thetbl As Range, LRow As Long Set thetbl = theBook.Sheets(1).Range("A1").CurrentRegion thetbl.Copy With ThisWorkbook.ActiveSheet LRow = .Range("A65536").End(xlUp).Row If LRow = 1 Then .Range("A" & LRow).PasteSpecial xlPasteValues Else .Range("A" & LRow + 1).PasteSpecial xlPasteValues End If End With Application.CutCopyMode = False End Sub -------------------------------------------------------------------------- 実際にはこのマクロは上手く動作していますが、1つ疑問があります。 「一度開いたファイルは開かない」というのはどの部分のおかげか、ということです。 当方初心者で、分かりづらい質問かもしれませんが、どうぞご教授お願いいたします。

  • エクセルマクロですべてのファイル保存時コメントだす

    エクセルのアドインでファイル保存するときに”保存しますか?”の ダイアログをすべてのファイルに出したいのですが、 うまくいきません。どなたかお教えください。 PERSONAL_SAVE.XLS というファイルに以下のマクロを作成し C:\Documents and Settings\***\Application Data\Microsoft\Excel\XLSTART VBのClass1に 'Option Explicit Public WithEvents App As Application Private Sub App_WorkbookBeforeSave(ByVal Wb As Workbook, ByVal SaveAsUI As Boolean, Cancel As Boolean) MsgBox ("保存しますか?") End Sub を作成し、 同じくVBのThisworkbookに Dim x As New Class1 Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) Set x.App = Application End Sub を作成します。 このときは、ほかのファイルに対しても 保存しますか? のメッセージがでます。 しかし、 このファイルをPERSONAL_SAVE.lxa として 保存し、ツール⇒アドイン で追加し、立ち上げても 同様な動きをしません。 どうしてでしょうか? インスタンス?の関係でしょうか?Private を Publicにしても同じでした。

専門家に質問してみよう