質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう!

新規登録して質問してみよう
ただいま回答率
85.50%
Windows 10

Windows 10は、マイクロソフト社がリリースしたOSです。Modern UIを標準画面にした8.1から、10では再びデスクトップ主体に戻され、UIも変更されています。PCやスマホ、タブレットなど様々なデバイスに幅広く対応していることが特徴です。

VBA

VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。

コピー

元のオブジェクトを破壊することなく、オブジェクトの複製を生成することをコピーと呼びます。

Q&A

2回答

3067閲覧

【VBA】同一マクロブックからの連続したシートのコピーをするとマクロブックが落ちる。

gyokusen

総合スコア12

Windows 10

Windows 10は、マイクロソフト社がリリースしたOSです。Modern UIを標準画面にした8.1から、10では再びデスクトップ主体に戻され、UIも変更されています。PCやスマホ、タブレットなど様々なデバイスに幅広く対応していることが特徴です。

VBA

VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。

コピー

元のオブジェクトを破壊することなく、オブジェクトの複製を生成することをコピーと呼びます。

0グッド

1クリップ

投稿2021/05/02 17:45

前提・実現したいこと

アンケートシートにシートの「送付」ボタンを設置しボタンクリックすると、アンケート集約ブックへアンケートシートをコピーするマクロを作成しました。この動作は1回目は確実に成功するのですが、2回目を実行すると処理途中でブックが落ちてしまいます。

発生している問題・エラーメッセージ

エラーメッセージは出ずにマクロが落ちる。(スタックオーバーフローでも発生したかのようだ・・・)

該当のソースコード

VBA

1Sub アンケート回答() 2'集約ブックへのシートのコピー追加は同じタイミングの場合は読み取りになる場合は終了する 3'このブックをコピーして以下の名前で保存する 4'QA_未登録_yyyymmdd_hhmmss 5'正常にオープンできたらシート追加作業を行う 6'集約ブックがあるフォルダに未登録のブックがあったらそのブックもオープンしてシート追加を行う 7'対象ブックのブック名をQA_登録済_yyyymmdd_hhmmssに書き換える 8'集約ブックを保存する 9 10Dim bkFullPath As String 11Dim folderPath As String 12Dim bkName As String 13Dim WS As Worksheet 14Set WS = ActiveSheet 15 16If WS.Cells(1, 9) = "" Then 17Else 18 MsgBox "すでにアンケート結果を送付しているので送付できません" & vbLf & _ 19 "送付日時:" & Format(WS.Cells(1, 9).Value, "yyyy/mm/dd hh:mm:ss") 20 Exit Sub 21End If 22 23Application.ScreenUpdating = False 24folderPath = ThisWorkbook.Path & "\" & "アンケート集約フォルダ" 25bkName = "アンケート集約ブック.xlsx" 26If folderPath = "" Then 27 bkFullPath = ThisWorkbook.Path & "\" & bkName 28Else 29 bkFullPath = folderPath & "\" & bkName 30End If 31Dim WB As Workbook 32Call BookOpen(WB, bkFullPath) 33If WB Is Nothing Then 34 GoTo Finally 35End If 36Dim cnt As Long 'コピー先ブックのシートの枚数 37'cnt = WB.Sheets.Count 38WS.Copy before:=WB.Sheets(1) 39Dim TS As Worksheet 40Set TS = ActiveSheet 41'TS.Name = Left(TS.Name, 5) & Format(Now, "_hhmmss") 42TS.Buttons.Delete 43'Call マクロボタンのキック先削除(TS) 44Call 未登録ブックの取り込み(folderPath, WB) 45'Application.DisplayAlerts = False 46WB.Save 47WB.Close 48Set WB = Nothing 49'Application.DisplayAlerts = True 50Application.ScreenUpdating = True 51Finally: 52 WS.Cells(1, 9) = Now 53 ThisWorkbook.Save 54 MsgBox "アンケート結果の送付が終了しました!" 55End Sub 56 57Sub BookOpen(WB As Workbook, bkFullPath As String) 58 Dim buf As String 59 60 'ファイルの存在チェック 61 buf = Dir(bkFullPath) 62 If buf = "" Then 63 MsgBox bkFullPath & vbCrLf & "は存在しません", vbExclamation 64 Exit Sub 65 End If 66 67 '同名ブックのチェック 68 For Each WB In Workbooks 69 If WB.Name = buf Then 70 MsgBox buf & vbCrLf & "はすでに開いています", vbExclamation 71 Exit Sub 72 End If 73 Next WB 74 75 'ここでブックを開く 76 If AlreadyOpenCheck(bkFullPath) Then 77 'MsgBox bkFullPath & vbLf & "は他の誰かが既に開いています。", vbExclamation 78 Dim folderPath As String 79 folderPath = Left(bkFullPath, InStrRev(bkFullPath, "\")) 80 ThisWorkbook.SaveCopyAs folderPath & "QA_未登録_" & Format(Now, "yyyymmdd_hhmmss") & ".xlsx" 81 Else 82 Set WB = Workbooks.Open(bkFullPath) 83 End If 84 85End Sub 86 87Function AlreadyOpenCheck(bkFullPath As String) As Boolean 88 On Error Resume Next 89 Open bkFullPath For Append As #1 90 Close #1 91 If Err.Number > 0 Then 92 AlreadyOpenCheck = True 93 Else 94 AlreadyOpenCheck = False 95 End If 96End Function 97 98Sub 未登録ブックの取り込み(folderPath, WB) 99Dim buf As String 100Dim QA As Workbook 101buf = Dir(folderPath & "\" & "QA_未登録_*.xlsx") 102 103Do While buf <> "" 104 105Set QA = Workbooks.Open(folderPath & "\" & buf) 106QA.Sheets(1).Copy before:=WB.Sheets(1) 107Application.DisplayAlerts = False 108Workbooks(buf).Close 109Application.DisplayAlerts = True 110 111buf = Dir() 112Loop 113 114End Sub 115 116

試したこと

色々やって分かったことはブックのファイル名がちがったり、フォルダが違う場所から同じブックを実行する場合ならば落ちる現象は生じていません。
1.アンケートブックをコピーして2つ用意する。
2.アンケート1.xlsm で アンケート集約ブック.xlsxに「アンケート」シートをコピー追加 成功
3.アンケート2.xlsm で アンケート集約ブック.xlsxに「アンケート」シートをコピー追加 成功
4.アンケート1.xlsm で アンケート集約ブック.xlsxに「アンケート」シートをコピー追加 成功
5.アンケート2.xlsm で アンケート集約ブック.xlsxに「アンケート」シートをコピー追加 成功
6.アンケート2.xlsm で アンケート集約ブック.xlsxに「アンケート」シートをコピー追加 失敗
➡ マクロ実行中にEXCEL自体が落ちる

補足情報(FW/ツールのバージョンなど)

Window10 64ビット バージョン 1903
OS 名: Microsoft Windows 10 Home
OS バージョン: 10.0.18362 N/A ビルド 18362
OS 製造元: Microsoft Corporation
OS 構成: スタンドアロン ワークステーション
Microsoft Excel 2016 MSO(16.0.13901.20366) 32ビット

気になる質問をクリップする

クリップした質問は、後からいつでもMYページで確認できます。

またクリップした質問に回答があった際、通知やメールを受け取ることができます。

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

guest

回答2

0

下記の手順でシートのコピー中に落ちる現象はなくなりました。
なおこの現象は別のブックから別のブックへのシートコピー処理では発生しません。

VBA

1Sub アンケート回答() 2'1.集約ブックへのシートのコピー追加はすでに別途オープンされていた場合は実施しない 3'2.その場合はブック自体をコピーして「QA_未登録_yyyymmdd_hhmmss.xlsm」の名前で保存する 4'3.正常に集約ブックがオープンできたらシート追加作業を行う 5'4.集約ブックがあるフォルダに未登録のブックがあったらそのブックをオープンしてシート追加を行う 6'5.対象ブックのブック名をQA_登録済_yyyymmdd_hhmmssに書き換える 7'6.(おまじない)本ブックのシートコピー処理の前にThisWorkbook.saveを行う 8'7.本ブックのアンケートシートを集約ブックにコピーする 9'8.集約ブックを保存する 10 11Dim bkFullPath As String 12Dim folderPath As String 13Dim bkName As String 14Dim WS As Worksheet 15Set WS = ActiveSheet 16 17If WS.Cells(1, 9) = "" Then 18Else 19 MsgBox "すでにアンケート結果を送付しているので送付できません" & vbLf & _ 20 "送付日時:" & Format(WS.Cells(1, 9).Value, "yyyy/mm/dd hh:mm:ss") 21 Exit Sub 22End If 23 24Application.ScreenUpdating = False 25folderPath = ThisWorkbook.Path & "\" & "アンケート集約フォルダ" 26bkName = "アンケート集約ブック.xlsx" 27 28If folderPath = "" Then 29 bkFullPath = ThisWorkbook.Path & "\" & bkName 30Else 31 bkFullPath = folderPath & "\" & bkName 32End If 33 34Dim WB As Workbook 35Call BookOpen(WB, bkFullPath, WS) 36 37If WB Is Nothing Then 38 Exit Sub 39End If 40 41Call 未登録ブックの取り込み(folderPath, WB) 42 43ThisWorkbook.Save 44WS.Copy before:=WB.Sheets(1) 45 46Dim TS As Worksheet 47Set TS = ActiveSheet 48TS.Buttons.Delete 49 50WB.Save 51WB.Close 52Set WB = Nothing 53 54Application.ScreenUpdating = True 55Finally: 56 WS.Cells(1, 9) = Now 57 ThisWorkbook.Save 58 MsgBox "アンケート結果の送付が終了しました!" 59End Sub 60 61Sub BookOpen(WB As Workbook, bkFullPath As String, WS As Worksheet) 62 Dim buf As String 63 64 'ファイルの存在チェック 65 buf = Dir(bkFullPath) 66 If buf = "" Then 67 MsgBox bkFullPath & vbCrLf & "は存在しません!" & vbLf & "アンケート実施者へ連絡願います", vbExclamation 68 Exit Sub 69 End If 70 71 '同名ブックのチェック 72 For Each WB In Workbooks 73 If WB.Name = buf Then 74 MsgBox buf & vbCrLf & "はすでに開いています!" & vbLf & "対象ブックを閉じてください", vbExclamation 75 Exit Sub 76 End If 77 Next WB 78 79 'ここでブックを開く 80 If AlreadyOpenCheck(bkFullPath) Then 81 Dim folderPath As String 82 folderPath = Left(bkFullPath, InStrRev(bkFullPath, "\")) 83 ThisWorkbook.SaveCopyAs folderPath & "QA_未登録_" & Format(Now, "yyyymmdd_hhmmss") & ".xlsm" 84 WS.Cells(1, 9) = Now 85 ThisWorkbook.Save 86 MsgBox "アンケート結果の送付が終了しました。" 87 Exit Sub 88 Else 89 Set WB = Workbooks.Open(bkFullPath) 90 End If 91 92End Sub 93 94Function AlreadyOpenCheck(bkFullPath As String) As Boolean 95 Dim FileNumber As Integer 96 FileNumber = FreeFile 97 On Error Resume Next 98 Open bkFullPath For Append As #FileNumber 99 Close #FileNumber 100 If Err.Number > 0 Then 101 AlreadyOpenCheck = True 102 Else 103 AlreadyOpenCheck = False 104 End If 105 On Error GoTo 0 106End Function 107 108Sub 未登録ブックの取り込み(folderPath, WB) 109Dim buf As String 110Dim QA As Workbook 111buf = Dir(folderPath & "\" & "QA_未登録_*.xlsm") 112Application.DisplayAlerts = False 113Do While buf <> "" 114Dim fullPath As String 115fullPath = folderPath & "\" & buf 116Set QA = Workbooks.Open(fullPath, 0, True) 117QA.Sheets(1).Copy before:=WB.Sheets(1) 118Dim TS As Worksheet 119Set TS = ActiveSheet 120TS.Buttons.Delete 121QA.Close 122Application.DisplayAlerts = True 123 124Dim newName As String 125 126newName = Replace(buf, "未登録", "登録済") 127Name folderPath & "\" & buf As folderPath & "\" & newName 128 129buf = Dir() 130Loop 131 132End Sub

投稿2021/05/03 03:32

gyokusen

総合スコア12

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

0

思いつきなので確証はありません。、
AlreadyOpenCheck関数を少し修正してみました。

VBA

1Function AlreadyOpenCheck(bkFullPath As String) As Boolean 2 Dim FileNumber As Integer 3 FileNumber = FreeFile 4 On Error Resume Next 5 Open bkFullPath For Append As #FileNumber 6 Close #FileNumber 7 If Err.Number > 0 Then 8 AlreadyOpenCheck = True 9 Else 10 AlreadyOpenCheck = False 11 End If 12 On Error Goto 0 13End Function

投稿2021/05/02 22:33

TanakaHiroaki

総合スコア1063

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

gyokusen

2021/05/03 01:19

取り替えて実行しましたが結果は同じでした。 でもこの結果調査の過程で発生を回避する手段が見つかりました。 きっかけを下さりありがとうございます。 <ブックが落ちるのはどの時点なのか調査するコードを埋め込みました> Dim z As Long Z = Z + 1 Call svOwn(z, WS) Sub svOwn(i As Long, WS As Worksheet) WS.Cells(i, 10) = i: WS.Cells(i, 11) = Now ThisWorkbook.Save End Sub すると正常にシートの追加を何回やっても落ちなくなりました。 最終的にどこで落ちているかと言えばシートのコピー作業をやっているところで落ちていました。 WS.Copy before:=WB.Sheets(1) このステートメントの直前に自分自身のセーブを行っていると起きないようです。 ThisWorkbook.Save WS.Copy before:=WB.Sheets(1) なぜシートコピー前に自分自身のブックをセーブしていると発生しないのかの理由 はわかりません。だれかご存知の方はいらっしゃいますでしょうか?
guest

あなたの回答

tips

太字

斜体

打ち消し線

見出し

引用テキストの挿入

コードの挿入

リンクの挿入

リストの挿入

番号リストの挿入

表の挿入

水平線の挿入

プレビュー

まだベストアンサーが選ばれていません

会員登録して回答してみよう

アカウントをお持ちの方は

15分調べてもわからないことは
teratailで質問しよう!

ただいまの回答率
85.50%

質問をまとめることで
思考を整理して素早く解決

テンプレート機能で
簡単に質問をまとめる

質問する

関連した質問