VBAで、以下を行いたいです。 あるドライブのフォルダに、csvファイルが複数あります。全てのcsv

VBAで、以下を行いたいです。

あるドライブのフォルダに、csvファイルが複数あります。全てのcsvのファイル名は、以下の形式です。

日本語5文字+数字5桁+日本語5文字+数字5桁
例として、あいうえお12345かきくけこ67890、のような感じです。

例で挙げた名前のファイルであれば、Excelファイルの最終行のA列に12345、B列に67890、C列にcsvファイルのB3セルの左から5文字めまでを、D列以降には、csvファイルのC1〜C20までをコピーします。

これをフォルダにあるcsvファイルの数だけ、行います。

教えて頂けます様に、よろしくお願いします。

No.1 ベストアンサー 回答者： WindFaller 回答日時： 2017/02/07 00:40

こんばんは。

最終行のA列に12345| B列に67890 |C列にcsvファイル
「B3セルの左から5文字めまで」
「D列以降には、csvファイルのC1〜C20まで」
をコピーします。

となっていますが、csvファイルのC1～C20 を、右横方向に埋めていくことだと推理してみました。

それと、文章的に不足している部分は、こちらの想像で補完しますが、試しにつくってみました。CSVをExcelで開けずに取り出すことを考えて作りました。

このような内容の前提で作りました。

file名：あいうえお12345かきくけこ67890.csv

A列　　　 B列
12345　67890、

C列
B3セルの左から5文字めまで, 例：abcdefg
abcde

D列
C1〜C20　を、D列からW列までコピー

なお、一部、正規表現でファイル名を取得する所*は、多少、失敗を誘発する可能性があるところです。 必ず、その条件に当てはまらないと、データは取得できません。


'// 標準モジュールのみ対象。
Sub GetDataFromCSV()
　'*******ユーザー設定　*******
　Const mPATH As String = "C:\Users\Test1\" '末尾は必ず、￥を入れてく多剤。
　If Right(mPATH, 1) <> "\" Then MsgBox "パス名に'\' がありません。", vbCritical: Exit Sub
　
　Dim RegEx As Object
　Dim FName As String
　Dim Ary As Variant, a As String, b As String
　Dim buf As Variant, buf2 As Variant
　Dim Lr As Long, i As Long, j As Long, k As Long, m As Long
　ReDim Ary(0)
　Ary(0) = ""
　FName = Dir(mPATH & "*.csv", vbNormal)
　Do While FName <> ""
　　If FName <> "." And FName <> ".." Then
　　　ReDim Preserve Ary(i) '動的変数にする
　　　Ary(i) = mPATH & FName
　　　i = i + 1
　　End If
　　FName = Dir
　Loop
　
　If UBound(Ary) < 1 Then MsgBox "ファイル名を取得出来ませんでした。", vbExclamation: Exit Sub
　
　Lr = Cells(Rows.Count, 1).End(xlUp).Row '最後の行を探す
　If Lr = 1 And Cells(1, 1).Value = "" Then Lr = 0
　
　Dim objFS As Object
　Set objFS = CreateObject("Scripting.FilesystemObject")
　
　Dim Ms
　Set RegEx = CreateObject("VBScript.RegExp")
　With RegEx
　　.Global = True: .IgnoreCase = False: .MultiLine = True
　End With
　RegEx.Pattern = "([0-9]{5})"
　Dim objText As Object
　For j = 1 To UBound(Ary)
　　FName = Dir(Ary(j))
　　Set Ms = RegEx.Execute(FName)
　　If Ms.Count = 0 Then MsgBox "ファイル名取得に失敗しました。", vbExclamation: Exit Sub
　　a = Ms(0).SubMatches(0) '*
　　b = Ms(1).SubMatches(0) '*
　　Cells(j + Lr, 1).Value = a: Cells(j + Lr, 2).Value = b
　　Set objText = objFS.OpenTextFile(Ary(j), 1, 0)
　　Do While objText.AtEndOfLine <> True
　　　buf = objText.Readline
　　　buf2 = Split(buf, ",")
　　　m = m + 1
　　　If m = 3 Then Cells(j + Lr, 3).Value = Left$(buf2(1), 5)
　　　Cells(j + Lr, m + 3).Value = buf2(2) 'C列
　　　If m > 19 Then Exit Do　'20過ぎたら離脱
　　Loop
　　objText.Close
　　m = 0
　Next j
　Set RegEx = Nothing
　Set objFS = Nothing
End Sub