[VBA]csvファイルを開いて保存（高速化）

いつもこちらの識者の皆様にはお世話になっております。
VBAのことで質問させてください。

毎日吐き出される複数のcsvファイルを、開いてファイル名を変えてxls形式に変更してパスワードをかけて保存する。
という処理を現在マクロで行っているのですが、特に不備はないものの、csvファイルの数が多く、時間がかかっています。
後学のために教えていただきたいのですが、この処理を高速化することは可能でしょうか？

現在はworkbooks.openでcsvを開き、workbook.saveasでファイル名・ファイル形式の変更とパスワードの設定をし、workbook.closeでファイルを閉じる。
という処理をfor iで回してやっています。

質問に不備不足等ございましたらご指摘ください。
ご面倒お掛けしますがよろしくお願いします。

No.2 回答者： WindFaller 回答日時： 2015/01/19 16:26

こんにちは。

一応、処理するファイルは、目視で確認できるようになっています。また、同じファイル名があった時は、枝番が作られてから保存されます。保存ファイル型は、xlExcel8 (97-2003 format in Excel 2007-2013, xls)　にしています。

ファイルフォルダと出力フォルダは、同じでも構いません。
もし、ブック名がぶつかることがあれば、枝番が付けられます。

'//
Sub CSVImport2Sheet()
　Dim orgHolder As String
　Dim rw As Long, i As Long, j As Long, k As Integer, l As Long, m As Long
　Dim Fn As Variant, Fnames As Variant
　Dim FNo As Integer, TextLine As String
　Dim LineBuf As Variant, U As Integer
　Dim AcSht As Worksheet, WbkName As String, newBk As Workbook
　Dim msg As String
　Const PSWD As String = "abc"　'パスワード
　Const EXT As String = ".xls" '文字列の先頭のピリオドは忘れないでください
　'
　''必ず、末尾には、　'￥'を入れてください。
　Const myHolder As String = "C:\Test1\" 'ファイルフォルダ
　Const ExHolder As String = "C:\Test2\" '出力フォルダ
　rw = 1 '書き出しの最初の行数
　orgHolder = ThisWorkbook.Path
　ChDir myHolder
　
　'複数ファイルでも選択できます。
　Fnames = Application.GetOpenFilename("CSV ファイル(*.csv),*.csv", MultiSelect:=True)
　If VarType(Fnames) = vbBoolean Then
　　Exit Sub
　End If
　Application.ScreenUpdating = False
　For Each Fn In Fnames
　　Set AcSht = Worksheets.Add(After:=Worksheets(Worksheets.Count))
　　FNo = FreeFile()
　　Open Fn For Input As #FNo 'ファイルインポート
　　Do Until EOF(FNo)
　　　Line Input #FNo, TextLine
　　　'「""」 の除去
　　　'TextLine = Application.Substitute(TextLine, """", "")
　　　LineBuf = Split(TextLine, ",")
　　　U = UBound(LineBuf)
　　　If U >= 0 Then
　　　　AcSht.Cells(rw + j, 1).Resize(, U + 1).Value = LineBuf
　　　End If
　　　j = j + 1
　　Loop
　　On Error Resume Next
　　Close #FNo
　　If WorksheetFunction.CountA(AcSht.UsedRange) > 0 Then '特に必要はないはず。空ファイルの除去
　　　Fn = Dir(Fn)
　　　'Debug.Print Fn 'ファイル名の確認
　　　WbkName = Mid$(Fn, 1, InStrRev(Fn, ".") - 1)
　　　AcSht.Name = WbkName
　　　AcSht.Move
　　　Set newBk = ActiveWorkbook
　　　k = 1
　　　'同名ファイルがある場合は、枝番が付けられます。
　　　If Dir(ExHolder & WbkName & EXT) = "" Then
　　　　newBk.SaveAs ExHolder & WbkName & EXT, xlExcel8, PSWD
　　　Else
　　　　Do Until Dir(ExHolder & WbkName & "_" & CStr(k) & EXT) = ""
　　　　　k = k + 1
　　　　Loop
　　　　newBk.SaveAs ExHolder & WbkName & "_" & CStr(k) & EXT, xlExcel8, PSWD
　　　End If
　　　l = l + 1
　　　newBk.Close False
　　Else
　　　m = m + 1
　　End If
　　 j = 0
　　On Error GoTo 0
　Next
　Application.ScreenUpdating = True
　
　Set AcSht = Nothing
　Set newBk = Nothing
　ChDir orgHolder
　 msg = CStr(l) & " 個のファイルを処理し"
　 msg = msg & IIf(m > 0, vbCrLf & CStr(m) & " 個のファイルが処理できませんでした。", "ました。")
　 MsgBox msg, 64
End Sub
'//

No.1 回答者： cj_mover 回答日時： 2015/01/18 21:39

こんにちは。

高速化というより、時間が掛かる処理の代用を探して時短を図る、
ということになると思います。

workbooks.openとworkbook.saveasは、避けようなく時間が掛かりますから、
この点を如何に工夫するか、ですね。

workbook.saveas に関しては、
扱うデータの総量を変えることが出来ない以上は、
ある程度避けようがないレベルだとは思います。
Excelで処理する範疇に限ってシステムを変更すれば、工夫は可能です。
保存する回数分、大きな時間を必要とする訳ですから、
例えば、幾つかの複数csvテキストファイルをひとつのシートやブックに纏めて運用するように
設計し直せば、workbook.saveasを実行する回数を減らせる分だけ時短に繋がります。
同じフォーマットのデータをひとつのシートに纏めるなどすれば、
時短に繋がる上に、管理もし易くなる場合もあるでしょう。
法令的に保管義務があるとしても、それは大元のcsvテキストファイルに適用されますから、
作成するExcelブックでは必要な処理に関係ないデータを省いても支障が無いようでしたら、
データの総量を減らすことも可能ですし、多少の時短は見込めます。
システム管理者と相談の上、概要が決まった場合に、必要ならまた質問してみて下さい。

前後して、
workbooks.open に関しては、
csvテキストファイルをテキストデータとしてＶＢＡ上で読み込み、
workbooks.addで開いたブックにテキストデータを展開する方法で相当な時短が見込めます。
私が良く使う方法をサンプルとして挙げておきます。
　　Open For Input # でcsvテキストファイルを読み込み、
　　カンマ区切りテキストをタブ区切りに整形し
　　DataObject経由でクリップボードへタブ区切りテキストを送る
　　新しいExcelブック（シート数は１）を追加し、
　　クリップボードデータをシートに貼り付け、
　　[名前を付けて保存]
といった処理の流れです。
この方法は、データをマージする処理などにも応用し易いやり方です。

但し、元のcsvテキストファイルの仕様として、
区切り文字以外にも（桁区切り等で）カンマを用いている場合には、
正規表現等を用いて、より堅実な文字列処理が必要になります。
テキストを読み込む以上は、どんなやり方をするにしても、
csvテキストファイルの（多種多彩な）仕様について
事前に正しく把握しておくことが対策の為に必須となります。
桁区切りにカンマを使っているcsvだと、少し面倒ですから、
それならExcelブックとして開いた方が簡単だ、という理由で、
殆どの人はcsvテキストファイルをExcelブックとして開く方を選んでいるのだと思います。

といった感じで、ピンポイントでニーズに合った回答を目指して、
補足と回答のやりとりを重ねて解決に近づく、というような課題ではないようです。
具体物を見れば具体的な手当てを提案・示唆することは可能でしょうけれど、それよりは、
"こんな方法もある"的な応え方が妥当に思いますし、あとは質問者さんの方で
考えてみて下さい。
とはいっても、疑問・補足・不備・不足があれば、なるべくお応えしますので。

' ' ＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
' ' 指定したフォルダにある.csvテキストファイルのデータをExcelブックとして保存する
Sub Re8895594()
　　Const S_PATH As String = "フォルダパス"　'　要指定
　　Const S_EXTN As String = ".csv"

　　Dim oDtObj As Object
　　Dim sTmp As String
　　Dim sBuf As String
　　Dim tnSh As Long
　　Dim nFree As Integer

' ' New DataObjectインスタンス生成:テキスト整形・貼り付けに使う外部オブジェクト
　　Set oDtObj = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")

' ' アプリケーションの描画更新抑止
　　Application.ScreenUpdating = False
' ' 新規ブックのシート数　現設定を確保してから　シート数１に指定
　　tnSh = Application.SheetsInNewWorkbook
　　Application.SheetsInNewWorkbook = 1

' ' テキスト読み込み用フリーナンバー
　　nFree = FreeFile
' ' Dir()関数で指定フォルダ内のcsvファイルを検索
　　sTmp = Dir(S_PATH & "\*" & S_EXTN)

　　Do While sTmp <> ""
' ' 各csvテキストを全文一度に読み込む
　　　　Open S_PATH & "\" & sTmp For Input As #nFree
　　　　　　sBuf = StrConv(InputB(LOF(nFree), #nFree), vbUnicode)
　　　　Close #nFree

' ' 各csvテキストのカンマをタブへ置換し、タブ区切りテキストに整形
　　　　sBuf = Replace(sBuf, ",", vbTab)
' ' タブ区切りテキストをDataObject経由でクリップボードへ送る
　　　　With oDtObj
　　　　　　.SetText sBuf
　　　　　　.PutInClipboard
　　　　End With

' ' 新しいExcelブックの名前（必要ならフォルダパス等）を指定
　　　　sTmp = Replace(sTmp, S_EXTN, ".xls")
　　　　With Workbooks.Add　'　出力用新規ブックを追加
' ' クリップボードデータを貼り付け
　　　　　　.Sheets(1).Paste
' ' ブック名・パスワード等を（必要に応じて）指定してExcelブックを[名前を付けて保存]
　　　　　　.SaveAs Filename:=sTmp, Password:="1234"　'　各引数を適宜指定
' ' 出力・保存済のExcelブックを閉じる
　　　　　　.Close
　　　　End With
　　　　oDtObj.Clear

' ' Dir()関数で再検索
　　　　sTmp = Dir()
　　Loop

　　Set oDtObj = Nothing　'　DataObjectを解放
' ' 新規ブックのシート数を元に戻す
　　Application.SheetsInNewWorkbook = tnSh
' ' アプリケーションの描画更新再開
　　Application.ScreenUpdating = True
End Sub

' ' ＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝