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

Question

前提・実現したいこと

アンケートシートにシートの「送付」ボタンを設置しボタンクリックすると、アンケート集約ブックへアンケートシートをコピーするマクロを作成しました。この動作は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

試したこと

色々やって分かったことはブックのファイル名がちがったり、フォルダが違う場所から同じブックを実行する場合ならば落ちる現象は生じていません。
１．アンケートブックをコピーして２つ用意する。
２．アンケート１.xlsm で　アンケート集約ブック.xlsxに「アンケート」シートをコピー追加　成功
３．アンケート２.xlsm で　アンケート集約ブック.xlsxに「アンケート」シートをコピー追加　成功
４．アンケート１.xlsm で　アンケート集約ブック.xlsxに「アンケート」シートをコピー追加　成功
５．アンケート２.xlsm で　アンケート集約ブック.xlsxに「アンケート」シートをコピー追加　成功
６．アンケート２.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ビット

Answer 1

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

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

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

Answer 2

思いつきなので確証はありません。、
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

Comments

[gyokusen]

取り替えて実行しましたが結果は同じでした。
でもこの結果調査の過程で発生を回避する手段が見つかりました。
きっかけを下さりありがとうございます。
＜ブックが落ちるのはどの時点なのか調査するコードを埋め込みました＞
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)

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