同じセルに数字があるファイルを開いて別のファイルにどんどん転記しては閉じていく×1000件・・・をExcelマクロで作る

昨日は、アンケートの下仕事をやった。
各ファイルの同じセルに数字の記入があって、それを開いて別のファイルにどんどん転記しては閉じていく・・・というのをExcelマクロで作るのだが。
最初は手作業でコピペしていたのだが、対象が1000件近くもあると、疲れてくるし間違いが起こるので、マクロにすることに。
数時間後、そのマクロが完成したはいいが、途中、処理が30件～70件目で止まる（Excelが応答なしになる）。
テキストボックスが大量に貼り付けてあるから重いのが理由の様子。
あと483エラーが頻発（オブジェクトが見つかりませんエラー）。
ブレークポイントを使って、ストップ＆ゴーを繰り返すやり方だと、必ずうまくいく。
原因がわからないので対症療法になり、コードの修正に時間がかかった。

以下は、よく止まって困ったコード（修正前。アドイン登録してショートカットキーで呼び出ししていたのでその処理を含む）

Sub AUTO_OPEN()
 'Ctrl + k
 Application.OnKey "^{k}", "TenkiData"
 End Sub
 
 Sub auto_close()
 Application.OnKey "^{k}"          '元に戻す
 End Sub
 
Public Sub TenkiData()
Dim l As Long
    ActiveSheet.Range("A799:IV799").Copy
    Windows("データ集約マクロ.xlsm").Activate
    Range("A65536").End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues    '値のみ
     
    ActiveWindow.ActivatePrevious
    Range("A801:B801").Copy
    Windows("データ集約マクロ.xlsm").Activate
    Range("IX" & ActiveCell.Row).PasteSpecial Paste:=xlPasteValues
     
    ActiveWindow.ActivatePrevious
    Range("C80").Copy
    Windows("データ集約マクロ.xlsm").Activate
    Range("IZ" & ActiveCell.Row).PasteSpecial Paste:=xlPasteValues
     
    Application.SendKeys "({HOME})", True
    ActiveWindow.ActivatePrevious
    ActiveWindow.Close SaveChanges:=False
     
End Sub

以下は修正後。集約先ファイルに記述。

Public Sub TenkiData()
 
    On Error GoTo myError
        Dim l As Long, waitTime As Date
         
        Dim ShellApp As Object
        Dim objFolder As Object
        Set ShellApp = CreateObject("Shell.Application")
        Set objFolder = ShellApp.BrowseForFolder(&H0, "フォルダを選択して [OK]をクリックしてください。", &H1)
         
        If Not objFolder Is Nothing Then
            strDir = objFolder.Items.Item.Path
        Else
            Exit Sub
        End If
         
        Set FS = CreateObject("Scripting.FileSystemObject")
        Set Fol = FS.GetFolder(strDir)
        Set Fil = Fol.Files
         
        Application.ScreenUpdating = False
        For Each MyFile In Fil
            If MyFile.Name Like "*.xls*" Then
                Workbooks.Open MyFile.Path
                Dim strWB As String
                strWB = ActiveWorkbook.Name
             
                ActiveSheet.Range("A799:IV799").Copy
                r = Workbooks("データ集約マクロ.xlsm").Worksheets("Sheet1").Range("A65536").End(xlUp).Offset(1).Row
                Workbooks("データ集約マクロ.xlsm").Worksheets("Sheet1").Range("A" & r).PasteSpecial Paste:=xlPasteValues                    '値のみ
                 
                ActiveSheet.Range("A801:B801").Copy
                Workbooks("データ集約マクロ.xlsm").Worksheets("Sheet1").Range("IX" & r).PasteSpecial Paste:=xlPasteValues
                 
                ActiveSheet.Range("C80").Copy
                Workbooks("データ集約マクロ.xlsm").Worksheets("Sheet1").Range("IZ" & r).PasteSpecial Paste:=xlPasteValues
                                
                ActiveWindow.Close SaveChanges:=False
                 
                Workbooks("データ集約マクロ.xlsm").Save
 
                waitTime = Now + TimeValue("0:00:03") '短時間でファイルを閉じられなくてエラーになるケースを回避
                Application.Wait waitTime
             
            End If
        Next
        Application.ScreenUpdating = True
    Exit Sub
myError:
    MsgBox Err.Description, vbExclamation
End Sub

以下、効果のあった対策：
・開いた直後にWaitを数秒かけるとよい（必須）。
・ActiveやSelectを使ってバタバタウィンドウを開閉するとうまくいかないケースがあったので、それらをなるべく使わないようにコード修正（必須）。
・ScreenUpdatingを使う。それとDisplayAlertの使い方を間違えていて、気がつかなかった・・・。
・ブラウザなどバックグラウンドで開いているメモリ食いのアプリを終了しておく（処理が格段に速くなる！）。
・読み込み対象データの置き場所を、USBメモリからではなくHDDにしたら成功率がかなり上がった（必須）。
・各ファイルの容量を調べてみると、1件だけ、容量が倍のものがあった。勝手にシートを複製していたため。不要シートを削除すると成功率が上がった。

効果があったかもと思われる対策：
・ワークブック名とワークシート名を明示。
・1件読み込み処理終了毎に保存する

ファイル一覧の取得方法で参考になったサイト：マクロについて、①フォルダ内のエクセルファイルを順番に開いて行く方法… – Yahoo!知恵袋

処理の最終検証確認で役に立ったサイト：Windows:フォルダ内のファイル名一覧を取得（出力）するには – 教えて！HELPDESK