昨日は、アンケートの下仕事をやった。
各ファイルの同じセルに数字の記入があって、それを開いて別のファイルにどんどん転記しては閉じていく・・・というのをExcelマクロで作るのだが。
最初は手作業でコピペしていたのだが、対象が1000件近くもあると、疲れてくるし間違いが起こるので、マクロにすることに。
数時間後、そのマクロが完成したはいいが、途中、処理が30件～70件目で止まる（Excelが応答なしになる）。
テキストボックスが大量に貼り付けてあるから重いのが理由の様子。
あと483エラーが頻発（オブジェクトが見つかりませんエラー）。
ブレークポイントを使って、ストップ＆ゴーを繰り返すやり方だと、必ずうまくいく。
原因がわからないので対症療法になり、コードの修正に時間がかかった。
以下は、よく止まって困ったコード（修正前。アドイン登録してショートカットキーで呼び出ししていたのでその処理を含む）
[code] 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[/code]
以下は修正後。集約先ファイルに記述。
[code]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[/code]
以下、効果のあった対策：
・開いた直後にWaitを数秒かけるとよい（必須）。
・ActiveやSelectを使ってバタバタウィンドウを開閉するとうまくいかないケースがあったので、それらをなるべく使わないようにコード修正（必須）。
・ScreenUpdatingを使う。それとDisplayAlertの使い方を間違えていて、気がつかなかった・・・。
・ブラウザなどバックグラウンドで開いているメモリ食いのアプリを終了しておく（処理が格段に速くなる！）。
・読み込み対象データの置き場所を、USBメモリからではなくHDDにしたら成功率がかなり上がった（必須）。
・各ファイルの容量を調べてみると、1件だけ、容量が倍のものがあった。勝手にシートを複製していたため。不要シートを削除すると成功率が上がった。
効果があったかもと思われる対策：
・ワークブック名とワークシート名を明示。
・1件読み込み処理終了毎に保存する
ファイル一覧の取得方法で参考になったサイト：マクロについて、①フォルダ内のエクセルファイルを順番に開いて行く方法… – Yahoo!知恵袋
処理の最終検証確認で役に立ったサイト：Windows:フォルダ内のファイル名一覧を取得（出力）するには – 教えて！HELPDESK
