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

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

ただいまの
回答率

87.49%

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

受付中

回答 2

投稿

  • 評価
  • クリップ 1
  • VIEW 511

score 12

前提・実現したいこと

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

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

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

該当のソースコード

Sub アンケート回答()
'集約ブックへのシートのコピー追加は同じタイミングの場合は読み取りになる場合は終了する
'このブックをコピーして以下の名前で保存する
'QA_未登録_yyyymmdd_hhmmss
'正常にオープンできたらシート追加作業を行う
'集約ブックがあるフォルダに未登録のブックがあったらそのブックもオープンしてシート追加を行う
'対象ブックのブック名をQA_登録済_yyyymmdd_hhmmssに書き換える
'集約ブックを保存する

Dim bkFullPath As String
Dim folderPath As String
Dim bkName As String
Dim WS As Worksheet
Set WS = ActiveSheet

If WS.Cells(1, 9) = "" Then
Else
    MsgBox "すでにアンケート結果を送付しているので送付できません" & vbLf & _
    "送付日時:" & Format(WS.Cells(1, 9).Value, "yyyy/mm/dd hh:mm:ss")
    Exit Sub
End If

Application.ScreenUpdating = False
folderPath = ThisWorkbook.Path & "\" & "アンケート集約フォルダ"
bkName = "アンケート集約ブック.xlsx"
If folderPath = "" Then
    bkFullPath = ThisWorkbook.Path & "\" & bkName
Else
    bkFullPath = folderPath & "\" & bkName
End If
Dim WB As Workbook
Call BookOpen(WB, bkFullPath)
If WB Is Nothing Then
    GoTo Finally
End If
Dim cnt As Long 'コピー先ブックのシートの枚数
'cnt = WB.Sheets.Count
WS.Copy before:=WB.Sheets(1)
Dim TS As Worksheet
Set TS = ActiveSheet
'TS.Name = Left(TS.Name, 5) & Format(Now, "_hhmmss")
TS.Buttons.Delete
'Call マクロボタンのキック先削除(TS)
Call 未登録ブックの取り込み(folderPath, WB)
'Application.DisplayAlerts = False
WB.Save
WB.Close
Set WB = Nothing
'Application.DisplayAlerts = True
Application.ScreenUpdating = True
Finally:
    WS.Cells(1, 9) = Now
    ThisWorkbook.Save
    MsgBox "アンケート結果の送付が終了しました!"
End Sub

Sub BookOpen(WB As Workbook, bkFullPath As String)
    Dim buf As String

    'ファイルの存在チェック
    buf = Dir(bkFullPath)
    If buf = "" Then
        MsgBox bkFullPath & vbCrLf & "は存在しません", vbExclamation
        Exit Sub
    End If

    '同名ブックのチェック
    For Each WB In Workbooks
        If WB.Name = buf Then
            MsgBox buf & vbCrLf & "はすでに開いています", vbExclamation
            Exit Sub
        End If
    Next WB

    'ここでブックを開く
    If AlreadyOpenCheck(bkFullPath) Then
        'MsgBox bkFullPath & vbLf & "は他の誰かが既に開いています。", vbExclamation
        Dim folderPath As String
        folderPath = Left(bkFullPath, InStrRev(bkFullPath, "\"))
        ThisWorkbook.SaveCopyAs folderPath & "QA_未登録_" & Format(Now, "yyyymmdd_hhmmss") & ".xlsx"
    Else
        Set WB = Workbooks.Open(bkFullPath)
    End If

End Sub

Function AlreadyOpenCheck(bkFullPath As String) As Boolean
    On Error Resume Next
    Open bkFullPath For Append As #1
    Close #1
    If Err.Number > 0 Then
        AlreadyOpenCheck = True
    Else
        AlreadyOpenCheck = False
    End If
End Function

Sub 未登録ブックの取り込み(folderPath, WB)
Dim buf As String
Dim QA As Workbook
buf = Dir(folderPath & "\" & "QA_未登録_*.xlsx")

Do While buf <> ""

Set QA = Workbooks.Open(folderPath & "\" & buf)
QA.Sheets(1).Copy before:=WB.Sheets(1)
Application.DisplayAlerts = False
Workbooks(buf).Close
Application.DisplayAlerts = True

buf = Dir()
Loop

End Sub

試したこと

色々やって分かったことはブックのファイル名がちがったり、フォルダが違う場所から同じブックを実行する場合ならば落ちる現象は生じていません。
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ビット

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

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

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

    クリップを取り消します

  • 良い質問の評価を上げる

    以下のような質問は評価を上げましょう

    • 質問内容が明確
    • 自分も答えを知りたい
    • 質問者以外のユーザにも役立つ

    評価が高い質問は、TOPページの「注目」タブのフィードに表示されやすくなります。

    質問の評価を上げたことを取り消します

  • 評価を下げられる数の上限に達しました

    評価を下げることができません

    • 1日5回まで評価を下げられます
    • 1日に1ユーザに対して2回まで評価を下げられます

    質問の評価を下げる

    teratailでは下記のような質問を「具体的に困っていることがない質問」、「サイトポリシーに違反する質問」と定義し、推奨していません。

    • プログラミングに関係のない質問
    • やってほしいことだけを記載した丸投げの質問
    • 問題・課題が含まれていない質問
    • 意図的に内容が抹消された質問
    • 過去に投稿した質問と同じ内容の質問
    • 広告と受け取られるような投稿

    評価が下がると、TOPページの「アクティブ」「注目」タブのフィードに表示されにくくなります。

    質問の評価を下げたことを取り消します

    この機能は開放されていません

    評価を下げる条件を満たしてません

    評価を下げる理由を選択してください

    詳細な説明はこちら

    上記に当てはまらず、質問内容が明確になっていない質問には「情報の追加・修正依頼」機能からコメントをしてください。

    質問の評価を下げる機能の利用条件

    この機能を利用するためには、以下の事項を行う必要があります。

回答 2

+1

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

Sub アンケート回答()
'1.集約ブックへのシートのコピー追加はすでに別途オープンされていた場合は実施しない
'2.その場合はブック自体をコピーして「QA_未登録_yyyymmdd_hhmmss.xlsm」の名前で保存する
'3.正常に集約ブックがオープンできたらシート追加作業を行う
'4.集約ブックがあるフォルダに未登録のブックがあったらそのブックをオープンしてシート追加を行う
'5.対象ブックのブック名をQA_登録済_yyyymmdd_hhmmssに書き換える
'6.(おまじない)本ブックのシートコピー処理の前にThisWorkbook.saveを行う
'7.本ブックのアンケートシートを集約ブックにコピーする
'8.集約ブックを保存する

Dim bkFullPath As String
Dim folderPath As String
Dim bkName As String
Dim WS As Worksheet
Set WS = ActiveSheet

If WS.Cells(1, 9) = "" Then
Else
    MsgBox "すでにアンケート結果を送付しているので送付できません" & vbLf & _
    "送付日時:" & Format(WS.Cells(1, 9).Value, "yyyy/mm/dd hh:mm:ss")
    Exit Sub
End If

Application.ScreenUpdating = False
folderPath = ThisWorkbook.Path & "\" & "アンケート集約フォルダ"
bkName = "アンケート集約ブック.xlsx"

If folderPath = "" Then
    bkFullPath = ThisWorkbook.Path & "\" & bkName
Else
    bkFullPath = folderPath & "\" & bkName
End If

Dim WB As Workbook
Call BookOpen(WB, bkFullPath, WS)

If WB Is Nothing Then
    Exit Sub
End If

Call 未登録ブックの取り込み(folderPath, WB)

ThisWorkbook.Save
WS.Copy before:=WB.Sheets(1)

Dim TS As Worksheet
Set TS = ActiveSheet
TS.Buttons.Delete

WB.Save
WB.Close
Set WB = Nothing

Application.ScreenUpdating = True
Finally:
    WS.Cells(1, 9) = Now
    ThisWorkbook.Save
    MsgBox "アンケート結果の送付が終了しました!"
End Sub

Sub BookOpen(WB As Workbook, bkFullPath As String, WS As Worksheet)
    Dim buf As String

    'ファイルの存在チェック
    buf = Dir(bkFullPath)
    If buf = "" Then
        MsgBox bkFullPath & vbCrLf & "は存在しません!" & vbLf & "アンケート実施者へ連絡願います", vbExclamation
        Exit Sub
    End If

    '同名ブックのチェック
    For Each WB In Workbooks
        If WB.Name = buf Then
            MsgBox buf & vbCrLf & "はすでに開いています!" & vbLf & "対象ブックを閉じてください", vbExclamation
            Exit Sub
        End If
    Next WB

    'ここでブックを開く
    If AlreadyOpenCheck(bkFullPath) Then
        Dim folderPath As String
        folderPath = Left(bkFullPath, InStrRev(bkFullPath, "\"))
        ThisWorkbook.SaveCopyAs folderPath & "QA_未登録_" & Format(Now, "yyyymmdd_hhmmss") & ".xlsm"
        WS.Cells(1, 9) = Now
        ThisWorkbook.Save
        MsgBox "アンケート結果の送付が終了しました。"
        Exit Sub
    Else
        Set WB = Workbooks.Open(bkFullPath)
    End If

End Sub

Function AlreadyOpenCheck(bkFullPath As String) As Boolean
    Dim FileNumber As Integer
    FileNumber = FreeFile
    On Error Resume Next
    Open bkFullPath For Append As #FileNumber
    Close #FileNumber
    If Err.Number > 0 Then
        AlreadyOpenCheck = True
    Else
        AlreadyOpenCheck = False
    End If
    On Error GoTo 0
End Function

Sub 未登録ブックの取り込み(folderPath, WB)
Dim buf As String
Dim QA As Workbook
buf = Dir(folderPath & "\" & "QA_未登録_*.xlsm")
Application.DisplayAlerts = False
Do While buf <> ""
Dim fullPath As String
fullPath = folderPath & "\" & buf
Set QA = Workbooks.Open(fullPath, 0, True)
QA.Sheets(1).Copy before:=WB.Sheets(1)
Dim TS As Worksheet
Set TS = ActiveSheet
TS.Buttons.Delete
QA.Close
Application.DisplayAlerts = True

Dim newName As String

newName = Replace(buf, "未登録", "登録済")
Name folderPath & "\" & buf As folderPath & "\" & newName

buf = Dir()
Loop

End Sub

 

投稿

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

0

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

Function AlreadyOpenCheck(bkFullPath As String) As Boolean
    Dim FileNumber As Integer
    FileNumber = FreeFile
    On Error Resume Next
    Open bkFullPath For Append As #FileNumber
    Close #FileNumber
    If Err.Number > 0 Then
        AlreadyOpenCheck = True
    Else
        AlreadyOpenCheck = False
    End If
    On Error Goto 0
End Function

投稿

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2021/05/03 10: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)

    なぜシートコピー前に自分自身のブックをセーブしていると発生しないのかの理由
    はわかりません。だれかご存知の方はいらっしゃいますでしょうか?

    キャンセル

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

  • ただいまの回答率 87.49%
  • 質問をまとめることで、思考を整理して素早く解決
  • テンプレート機能で、簡単に質問をまとめられる

関連した質問

同じタグがついた質問を見る

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