大量のCSVデータを行列の変換をしてエクセルデータにまとめる方法について

質問

CSVファイルが4000個ほどあり、VBAを用い、そのファイルの行列変換をして、１つのエクセルファイルにまとめたいのですが、うまくいきません。どなたか教えていただけないでしょうか？

CSVファイルは、以下の様な２列200行位あるものを、２列目のみ取り出し、エクセルファイルには１行(列ではなく)にして取り出したいのです。

変換前データー

A列 　 B列

B013 毛
B014 54
B015 ポリエステル
B016 36
B017 絹
B018 10
B020 0
B022 0
B023 ポリエステル
B024 0
B025 キュプラ
B026 0
B028 0
B030 0
B032 0
　・　　・
　・　　・
　・　　・

取り込み変換後データ

1行：　毛　54　ポリエステル　36　絹　10　0　0　ポリエステル　0 キュプラ　0　0　0　0

のようにしたいのです。
どなたかお教えいただけないでしょうか？
よろしくお願いいたします。

回答No.2

merlionXX · ベストアンサー

4000個もあるんじゃマクロじゃなきゃできませんよね。
次の手順を試してみてください。
その4000個程度のCSVファイルが入っているフォルダーに、以下のマクロを書いたエクセルBOOKを保存してください。（パス取得のため必ず「保存」してください。）
そのフォルダー内の全てのCSVファイルから、B1：B256の範囲のデータを読み込み、エクセルの.Sheets("Sheet1")の１行目から順に転記していきます。
読み込むのをB1：B256としたのは、わたしのエクセルが2007ではないので、行列を入れ替えたとき列が256列までしかないからです。でも200件程度のデータなら大丈夫ですね？

Sub test01()
Dim myFile As String, MyPath As String '変数宣言
Dim i As Long
Dim wb As Workbook
MyPath = ThisWorkbook.Path & "\" '自分のパスを取得
myFile = Dir(MyPath & "*.csv", vbNormal) 'パス内のcsvファイル
Application.ScreenUpdating = False '画面更新停止
Application.Calculation = xlCalculationManual '自動計算停止
Do Until myFile = "" '対象ファイルがなくなるまで
Set wb = Workbooks.Open(MyPath & "\" & myFile) '選択したファイルを開く
ThisWorkbook.Sheets("Sheet1").Range("A1:IV1").Offset(i).Value = _
Application.Transpose(wb.Sheets(1).Range("B1:B256").Value) '行列を入れ替えて転記
i = i + 1 'カウント
wb.Close (False) '開いたファイルを閉じる
myFile = Dir '次のファイルを検索
Loop '繰り返し
Application.Calculation = xlCalculationAutomatic '自動計算停止解除
Application.ScreenUpdating = True '画面更新停止解除
Set wb = Nothing
MsgBox i & "件のCSVファイルから転記しました。", vbInformation, " " & Environ("UserName") & "さん (o^-')v "
End Sub

お礼

ありがとうございました。
助かりました。

回答No.4

n-jun

Ａ列に半角スペースで区切って連結した値を代入すると解釈しました。
ＣＳＶファイルはブックと同じフォルダにあるとします。

クリップボードを操作する(1)
http://www.officetanaka.net/excel/vba/tips/tips20.htm
【ダイレクトに格納/取得する】
ツール＞参照設定をお忘れなく。

Sub try()
Dim Clip_B As New DataObject
Dim wb As Workbook
Dim r As Range
Dim Fname As String, Fdir As String

Set r = ThisWorkbook.Worksheets("Sheet1").Range("A1")
Fdir = ThisWorkbook.Path & "\"
Fname = Dir(Fdir & "*.csv", vbNormal)

Application.ScreenUpdating = False

Do Until Fname = ""

Set wb = Workbooks.Open(Fdir & Fname)
wb.Worksheets(1).Range("B1:B200").Copy '２００行固定

With Clip_B
.GetFromClipboard
r.Value = Replace(.GetText, vbCrLf, " ")
End With

Application.CutCopyMode = False
wb.Close False

Set r = r.Offset(1)
Fname = Dir()
Loop

Application.ScreenUpdating = True
Set wb = Nothing
Set r = Nothing
End Sub

勘違いでしたらスル～して下さい。

回答No.3

DOUGLAS_

＞CSVファイルが4000個ほどあり
とのことですので、[Open ステートメント] を使用して、[シーケンシャル入力モード] で開いた CSVファイル の「２列目のみ取り出し」て横方向に並べました。
　１列目に CSVファイルのファイル名を配置しましたが、不要の場合は
Cells(i, 1) = Replace(MyName, ".CSV", "")
j = 1
の２行を
j = 0
の１行に差し替えてください。

　また、
MyPath = "D:\hoge\hoge\hoge\"
の行は、CSVファイルの保存されたフォルダの「フルパス & "\"」を指定します。
　merlionXX さんの [回答番号：No.2] のように、CSVファイルと同じフォルダに保存したブックで作業をされるときは、
MyPath = ThisWorkbook.Path & "\"
で結構です。

　「On Error Resume Next」・「On Error GoTo 0」の２行は、「２列目」にデータがなかった場合に配列の２番目の要素「Split(InputData, ",")(1)」がなく、インデックス エラーになりますので、エラー処理を施しています。

　なお、コーディングは、[Dir 関数]・[EOF 関数] の使用例を参考にして書きました。
　同一フォルダに「250行×3列」の CSVファイル を256個作成して試行してみましたが、私の低スペックパソコンで作業時間は１８秒（１列目の見出しを省くと１７秒）でした。

Sub ReadCSV()
　Dim MyPath As String
　Dim MyName　As String
　Dim i As Integer, j As Integer
　Dim InputData As String
　Application.ScreenUpdating = False
　Application.Calculation = xlCalculationManual
　MyPath = "D:\hoge\hoge\hoge\"
　MyName = Dir(MyPath & "*.CSV", 3)
　Do While MyName <> ""
　　i = i + 1
　　Cells(i, 1) = Replace(MyName, ".CSV", "")
　　j = 1
　　Open MyPath & MyName For Input As #1
　　Do While Not EOF(1)
　　　j = j + 1
　　　Line Input #1, InputData
　　　On Error Resume Next
　　　Cells(i, j) = Split(InputData, ",")(1)
　　　On Error GoTo 0
　　Loop
　　Close #1
　　MyName = Dir
　Loop
　Application.Calculation = xlCalculationAutomatic
　Application.ScreenUpdating = True
End Sub

お礼

ご教授ありがとうございました。
あの後データが15000件に膨らみましたが、
スムーズに取り込むことができました。
本当に助かりました。
ありがとうございました。

回答No.1

shintaro-2

VBAでなければならない理由が良くわかりませんが、

要は、Ｂ列を切り出して、改行をカンマに置換すれば済むのではないですか？

MS-Wordやテキストエディタで容易にできることですが