エクセル CSV 連続取り込み まとめる

質問

みなさまこんにちは、またもや質問です

よろしくお願いします。

ＣＳＶのファイルが多くありそれをまとめる方法
１　ＣＳＶの中身として1行目から記入されているが
　　必要なのは7行目（B7からK7まで）
２　行方向は最大300行ですが記入されていない行もある
　　（B列が空白なら取り込まない方が良いが別に取り込んでも良い　後でソートして集計する予定なので）
３　縦方向に貼り付けてまとめたい

４　出来ればフォルダー丸ごとか、ファイル名のどこかをみてそのファイルだけを自動で・・・

最終はＢ列を基準にソートを行い集計する。

このような場合は、何も考えずに1つずつファイルを開いてコピーエリアをB7:ｋ308までをコピーして行く方が良いのでしょうか？それとも、FOR　NEXTなどを使用していった方がすっきりするでしょうか？

回答No.5

hana-hana3 · ベストアンサー

修正版です。
取り込みデータのチェック等を加えました。

Sub ReadCsv2()

Dim F As Variant
Dim buf As String
Dim line As Long
Dim Dline As Long
Dim Data As Variant
Dim k As Integer
Close
Const Path As String = "C:\Tmp\"

If Dir(Path, vbDirectory) = "" Then
MsgBox "指定されたフォルダはありません。"
Exit Sub
End If

F = Dir(Path & "*.csv")
With Sheets("Sheet2") '記入シート
Do While F <> ""
Open Path & F For Input As #1
Do Until EOF(1)
Dline = Dline + 1
Line Input #1, buf
If Dline >= 7 And buf <> "" Then '入力行
Data = Split(buf, ",")
If IsArray(Data) And UBound(Data) > 0 Then
If Data(1) <> "" Then
line = .Range("B65536").End(xlUp).Row + 1
If line = 2 Then
If .Range("B1") = "" Then line = 1
End If
'記入部分 Ａ列を記入しない場合、k = 1
For k = 0 To UBound(Data)
.Cells(line, k + 1) = Data(k)
If k >= 10 Then Exit For
Next
End If
End If
End If
Loop
Close #1
F = Dir()
Dline = 0
Loop
End With
End Sub

お礼

ありがとうございます。
思ったとおりの動きで非常にありがたく感謝します
今回のものをベースに少しずつ拡張さしていただきたいと思います。
また何かありましたらよろしくお願いします。

回答No.6

Wendy02

＞7行目から　の　から　を忘れておりました・・・
ということでしたら、

'ワークシートに出力
'元のコード
　ActiveSheet.Cells.ClearContents　'アクティブシートの消去
　For j = LBound(myData()) To UBound(myData())
　　OutData = Split(myData(j), ",")
　　If UBound(OutData) > -1 And UBound(OutData) > 9 Then
　　　Cells(j + 1, 1).Resize(, 11) = OutData　'←
　　ElseIf UBound(OutData) > -1 And UBound(OutData) < 10 Then
　　　Cells(j + 1, 1).Resize(, UBound(OutData) + 1) = OutData　'←
　　End If
　Next j

この２行を
前:
　　Cells(j + 1, 1).Resize(, 11) = OutData　'←
・
・
　　Cells(j + 1, 1).Resize(, UBound(OutData) + 1) = OutData　'←

後:
　　Cells(j + 7, 1).Resize(, 11) = OutData　'←
・
・
　　Cells(j + 7, 1).Resize(, UBound(OutData) + 1) = OutData　'←

に換えて、

最後から11行目の
'前:
Range("A1").CurrentRegion.Sort _
　　　 Key1:=Range("B1"), _
　　　 Order1:=xlAscending, _
　　　 Header:=xlGuess, _
　　　 OrderCustom:=1, _
　　　 MatchCase:=False, _
　　　 Orientation:=xlTopToBottom, _
　　　 SortMethod:=xlPinYin
　Application.ScreenUpdating = True
　MsgBox "終了!", 64

'後:
'上から
Range("A7").CurrentRegion.Sort _
　　　 Key1:=Range("B7"), _

に変更してください。
ただし、現在のコードは、A列は出ていますので、不必要なら、

　Application.ScreenUpdating = True
　Range("A7", Range("A65536").End(xlUp)).ClearContents　'ここに加えてください。
　MsgBox "終了!", 64
End Sub

最後の部分をこのように変更してください。なお、後先になりますが、コードは、標準モジュールに書くのが一般的です。

お礼

ありがとうございます。
大変参考になりました、また質問させていただいた時にはよろしくお願いします。

回答No.4

hana-hana3

記入データはDataという配列に入るので、必要な処理を加えてください。

Sub ReadCsv()

Dim F As Variant
Dim buf As String
Dim line As Long
Dim Data As Variant
Dim k As Integer
Close
Const Path As String = "C:\"

If Dir(Path, vbDirectory) = "" Then
MsgBox "指定されたフォルダはありません。"
Exit Sub
End If

F = Dir(Path & "*.csv")
Do While F <> ""
Open Path & F For Input As #1
Do Until EOF(1)
line = line + 1
Line Input #1, buf
If line = 7 Then '入力行
Close #1
Data = Split(buf, ",")
With Sheets("Sheet2") '記入シート
line = .Range("A65536").End(xlUp).Row + 1
'記入部分
'入力範囲制限なし
For k = 0 To UBound(Data)
.Cells(line, k + 1) = Data(k)
Next
End With
Exit Do
End If
Loop
F = Dir()
line = 0
Loop
End Sub

補足

ありがとうございます。
申し訳ありません、質問に記入漏れがありました
7行目　から　の　から　を書き忘れておりました
大変申し訳ありませんでした。

回答No.3

Wendy02

なお、コードの上から９行目の定数は、ユーザーオプションですから、お間違いありませんように。
必要に応じて、実際のフォルダーを設定しなおしてください。
Const UserPath As String = "C:\My Documents\Excel"

実質的には、以下の2行は、なくても構いません．
Const UserPath As String = "C:\My Documents\Excel"
　ChDir UserPath

補足

ありがとうございます。
質問に記入漏れがありました　大変申し訳ありません
7行目から　の　から　を忘れておりました・・・
いつもいつもありがとうございます。

回答No.2

Wendy02

必要なのは7行目（B7からK7まで）...7行目だけ取り出します。
フォルダー丸ごとか、ファイル名のどこか...GetOpenFilename で取り出しますが、Dir()関数で一括の方法もあります。

なお、これは、ActiveSheetを一旦消去して、そこに書き込むものです。
あたりまえですが、ランダムファイルではないので、ループで７行目を探しだしています。そこが完全に、空行でない限りは、取り出します。また、11列以上のCSV の行は、11列までで、それ以下はすべて、シートに書き出します。
なお、FileSystemObjectを使う方法も作ってみましたが、差がないので、Line Inputにしました。
並び替えは、データの種類がわからないので、フル・オプションにしました。場合によっては省略できます。

Sub CsvConslolidateOffice()
　Dim FileNames As Variant
　Dim FileNo As Integer
　Dim CsvLine As String
　Dim myFile As Variant
　Dim myData() As Variant
　Dim i As Long, j As Long, k As Long
　Dim OutData As Variant
　Const UserPath As String = "C:\My Documents\Excel"
　ChDir UserPath
　FileNames = Application.GetOpenFilename _
　　　　("Excel(*.csv),*.csv", MultiSelect:=True)
　If VarType(FileNames) = vbBoolean Then Exit Sub
'テキストラインのインポート
　For Each myFile In FileNames
　　FileNo = FreeFile
　　Open myFile For Input As #FileNo
　　Do While Not EOF(1)
　　　Line Input #FileNo, CsvLine
　　　If Len(CsvLine) > 0 And i = 6 Then 'スキップ (iの初期値=0)
　　　　ReDim Preserve myData(k)
　　　　myData(k) = CsvLine
　　　　 k = k + 1
　　　End If
　　　i = i + 1
　　　If i = 7 Then Exit Do
　　Loop
　　i = 0
　　Close #FileNo
　Next myFile
　'ワークシートに出力
　ActiveSheet.Cells.ClearContents　'アクティブシートの消去
　Application.ScreenUpdating = False
　For j = LBound(myData()) To UBound(myData())
　　OutData = Split(myData(j), ",")
　　If UBound(OutData) > -1 And UBound(OutData) > 9 Then
　　　Cells(j + 1, 1).Resize(, 11) = OutData
　　ElseIf UBound(OutData) > -1 And UBound(OutData) < 10 Then
　　　Cells(j + 1, 1).Resize(, UBound(OutData) + 1) = OutData
　　End If
　Next j
　Range("A1").CurrentRegion.Sort _
　　　　 Key1:=Range("B1"), _
　　　　 Order1:=xlAscending, _
　　　　 Header:=xlGuess, _
　　　　 OrderCustom:=1, _
　　　　 MatchCase:=False, _
　　　　 Orientation:=xlTopToBottom, _
　　　　 SortMethod:=xlPinYin
　Application.ScreenUpdating = True
　MsgBox "終了!", 64
End Sub

回答No.1

0shiete

>必要なのは7行目（B7からK7まで）

とありますので、Ｂ７からＫ７までをコピーすればよいと思います。Ｂ７：Ｋ３０８である必要はないのでしょうか？
それから、数が多いでしょうからループは使用した方がよいと思います。

補足

ありがとうございます。
質問一部間違ってます　大変申し訳ありません
7行目からの　から　を記入忘れておりました