IT仕事

同じセルに数字があるファイルを開いて別のファイルにどんどん転記しては閉じていく×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

-IT仕事

執筆者:

関連記事

no image

Excelで使える祝日判定のWebAPIを見つけた

Excelの関数には、曜日を判定できる関数(WEEKDAY)が用意されている。また、表示だけなら書式設定でもできる。しかし祝日となると、関数も何も、用意されていない。 祝日は年により、突然増えたり、「 …

no image

パンフ

今日、ちょっとした託物があってお客様のところを訪ねた。 またついでに、このたび新しく制作した会社案内もついでに見てもらおうと持参した。 対応した女性に肝心のをお渡しした後、「会社案内をこのたび新しくし …

no image

CSSメニューとその下のFlashムービーが重なって見えない

WordPressのTwenty-elevenのテンプレートを元にして、新たなテーマを作っている。 メニューの下にFlashアニメーションを配置したのだが、サブメニューがすっと表示されるときに、アニメ …

no image

フリースポット

仕事で宿泊施設。 公衆無線LAN構築を提案、いい感触。 個人的興味の深い仕事に、よし今度こそはと。

no image

昨日の続きの嬉しさよ

何度も落とされながらも「再チャレンジ」(笑)した結果、なんとか今年の試験で引っかかり、悲願の合格証書を手にした。 う、うれしいー! 昨日はビールとポテチでお祝いした。 振り返ると、結構難しかったなー、 …