補遺
追加回答が望めそうにないので一旦BAを設定してクローズさせていただきます。
結論的には
・たぶんADOが一番早い?
・(個人的見解)pandas.read_csvでの取り込みの方が実装楽そうだし速度検証したい
に落ち着くと思うので読み飛ばしていただいて構いません。
違う意見あれば今後も回答いただければと思います。(随時確認します)
前提
生産系工場で検査データの集計を行っています
検査データは1ファイル25kBのcsv形式で、1日で約1500-4000ファイルほど出力されています
各ファイルのデータ長は固定で、
A1:Y2->時刻情報など基本データ(先頭見出し)
A4:IS20->検査データ(先頭見出し、データ16行)
となっています。
集計ではA列に$B$2の時刻データ、C:D列にFN:5:FO20の検査データを抽出して縦結合しています。
ファイルのパス関係は
親フォルダ
└Lot1-yyyymmddhhnnss.csv(たくさん)
└マクロファイル
です。
実現したいこと
現在csvの取り込みにworkbooks.openを使用しているため非常に処理が遅く、高速化を図りたいです。
csvなんだからopenステートメントを使えやって話ではあるんですが、浅学のため一行単位ではなくセル指定での抽出方法がまったく検討がつかず、どう調べればいいかすら判らない状態です。
可能であればお勧めの手法やサイト、これは調べとけって情報等あればご教授いただければ幸いです。
発生している問題・エラーメッセージ
エラーは発生していませんが、処理に非常に時間が掛かります(弊環境で1日分約15分ほど)
一度に一か月分ほど一括で集計したりすることもあるのでかなり工数を圧迫されます。
該当のソースコード
VBA
1Sub Get_hogehoge_data() 2 3 Dim form As Worksheet 4 Set form = ThisWorkbook.ActiveSheet 5 Dim entRow As Long 6 7 8 Dim productionTime As Date 9 10 Dim wb As Workbook 11 Dim ws As Worksheet 12 Dim cnt As Long: cnt = 0 13 14 Dim t1 As Long, t2 As Long 'Timer 15 16 17 CreateObject("WScript.Shell").currentdirectory = ThisWorkbook.path 18 19 Dim wbn As Variant 'ファイル名群格納用配列 20 wbn = Application.GetOpenFilename(filefilter:="csvファイル,*.csv", MultiSelect:=True) 21 22 'wbnが配列じゃない(=キャンセルが押された)場合は通知して終了 23 If Not IsArray(wbn) Then 24 MsgBox "データが選択されませんでした" 25 Exit Sub 26 End If 27 28 29 30 t1 = Timer 31 Call FastMode(True) 32 Dim s As Variant 33 For Each s In wbn 34 35On Error GoTo ERR_Label 36 37 '↓これが死ぬほど遅い 38 Set wb = Workbooks.Open(s) 39 Set ws = wb.Sheets(1) 40 productionTime = ws.Cells(2, 2).Value 41 42 entRow = form.Cells(Rows.Count, 1).End(xlUp).Row + 1 '挿入行設定 43 44 ws.Range("FN5:FO20").Copy Destination:=form.Cells(entRow, 3) 45 form.Range(form.Cells(entRow, 1), form.Cells(entRow + 15, 1)).Value = productionTime 46 47 48 Set ws = Nothing 49 wb.Close saveChanges:=False 50 cnt = cnt + 1 51 Debug.Print cnt '進捗確認用 52 Next 53 54 '実行終了 55 t2 = Timer 56 Debug.Print t2 - t1 & "秒" 57 58PostProcess: 59 Set fso = Nothing 60 Call FastMode(False) 61 Exit Sub 62 63ERR_Label: 64 MsgBox "エラーが発生しています。デバッグモードで原因を確認してください。" 65 Resume PostProcess 66End Sub 67
試したこと
『bookを開かずにデータを貼付け』(sa) を参考に外部参照を埋め込む方式を試してみましたが、実行はできるものの参照エラーが返ってきました。
どうやら弊環境では一度でも該当ファイルを開かないと参照してくれないようです(試しに1ファイルだけ開いたらそのファイル箇所のみ参照してくれました)
VBA
1Sub Get_hogehoge_data改() 2 3 Dim wbn As Variant 'ファイル名群格納用配列 4 5 CreateObject("WScript.Shell").currentdirectory = ThisWorkbook.path 6 7 wbn = Application.GetOpenFilename(filefilter:="csvファイル,*.csv", MultiSelect:=True) 8 9 'wbnが配列じゃない(=キャンセルが押された)場合は通知して終了 10 If Not IsArray(wbn) Then 11 MsgBox "データが選択されませんでした" 12 GoTo PostProcess 13 End If 14 15 Dim form As Worksheet 16 Set form = ThisWorkbook.ActiveSheet 17 Dim entRow As Long 18 19 Dim data As String 20 Dim fso As New FileSystemObject 21 Dim fname As String 22 Dim path As String 23 Dim productionTime As String 24 25 Dim cnt As Long: cnt = 0 26 27 Dim t1 As Long, t2 As Long 28 29 t1 = Timer 30 Call FastMode(True) 31 32 Dim s As Variant 33 For Each s In wbn 34 35On Error GoTo ERR_Label 36 37 path = fso.GetParentFolderName(s) 38 fname = fso.GetBaseName(s) 39 40 productionTime = "'" & path & "\[" & fname & ".csv]" & fname & "'!$B$2" 41 data = "'" & path & "\[" & fname & ".csv]" & fname & "'!FN5:FO20" 42 43 44 entRow = form.Cells(Rows.Count, 1).End(xlUp).Row + 1 45 46 47 form.Range(form.Cells(entRow, 3), form.Cells(entRow + 15, 4)).Formula _ 48 = "=" & data 49 50 form.Range(form.Cells(entRow, 1), form.Cells(entRow + 15, 1)).Formula _ 51 = "=" & productionTime 52 53 54 Set ws = Nothing 55 wb.Close saveChanges:=False 56 cnt = cnt + 1 57 Debug.Print cnt '進捗確認用 58 Next 59 '実行終了 60 t2 = Timer 61 Debug.Print t2 - t1 & "秒" 62 63PostProcess: 64 Set fso = Nothing 65 Call FastMode(False) 66 Exit Sub 67 68ERR_Label: 69 MsgBox "エラーが発生しています。デバッグモードで原因を確認してください。" 70 Resume PostProcess 71End Sub
こちら224.CSVファイルを開かずに指定列のみを抽出取得するはどうやら列単位での抽出のみのようで、今回のように余計な行を含む場合は駄目そうなので断念しました。
個人的最終手段としてはExcel4Macroですが、可読性と拡張性に難があるのと古いマクロのため今後互換性が消える可能性に不安材料が残ります。
補足情報(FW/ツールのバージョンなど)
弊環境です
Corei5-8600 3.1GHz/RAM8GB
x64ベース
Excel2019/x32
回答1件
あなたの回答
tips
プレビュー
バッドをするには、ログインかつ
こちらの条件を満たす必要があります。
2022/10/07 10:24