複数のcsvファイルから特定の列を抜き出して1つのシートにまとめるExcelマクロ

データ処理をしていると大量のcsvファイルから

特定の行や列を抜き出して1つのExlファイルにまとめる必要が出てくるときがある。

十数シートくらいなら手でちまちまやるのも手だが、数百になるとそうもいかないのでExcelマクロを作成した。

プログラミングの知識は無いに等しいが、「Excel」「vba」「マクロ」など関連キーワードをたどっていくつかのサイトで公開されているマクロを見て近いものを拝借し、自分の目的に合うように一部修正するなどを繰り返して簡単な部分は分かるようになった。 

対象としたCSVファイルは下図のように細胞の数と面積のカウントをしたものとする（適当に作ったダミーファイルだが…）。画像中に黒色で示された細胞に対応するNoがA列、各細胞面積の計算結果がB列に格納されている。

経時データやzスタック画像を処理するとこのようなcsvファイルが連番で数十～数百生成されることになる。

解析画像

全てのcsvからB列のAreaを抜き出して、1番目の画像中の細胞AreaをB列、２番目の画像中の細胞AreaをC列・・・と順に格納し、各列の1行目にはそれぞれに対応する写真の番号を順に格納する（今回の場合はcsvファイル名の末尾３文字がｚ方向のスライス番号に対応するためcsvシート名の後ろ３文字を抜き出している）。

pathに処理したいCsvファイルの入っているフォルダの絶対パスを入れて走らせると、各csvファイルのB列が一つのシートにまとまるようになっている。

今回は各画像だいたい2000少々の細胞数なので余裕を見て3000行まで抜き出して貼り付けするようになっている。

Sub csv_area_extract()
Const path = "C:￥user￥…￥test￥" '処理したいフォルダのパス（最後に￥を忘れないこと※）※Macの場合は￥の代わりに/で区切る

Dim fname As String
Dim ws As Worksheet
Dim i As Long

Application.ScreenUpdating = False
Set ws = Sheets.Add
i = 1
'Dir 関数により指定したフォルダ内の指定ファイルをLoop処理
fname = Dir(path & "*.csv") 'csv ファイルに限定
Do Until Len(fname) = 0
If fname <> ThisWorkbook.Name Then
With Workbooks.Open(Filename:=path & fname, _
UpdateLinks:=0, _
ReadOnly:=True)
With .Sheets(1)
ws.Cells(2, i + 1).Value = Right(ActiveSheet.Name, 3)　'シート名の末尾3文字を採取して順に新しいシートに埋め込む
ws.Cells(3, i + 1).Resize(2999).Value = .Range("B2:B3000").Value　'B列2行目～3000行目まで採取して新しいシートに貼り付け
End With
.Close savechanges:=False
End With

i = i + 1
If i > ws.Columns.Count Then
i = 1
Set ws = Sheets.Add
End If
End If
fname = Dir()
Loop
'1 列⽬に⾏番号
Range("A3").Value = 1
Range("A4").Value = 2
Range("A3:A4").AutoFill Destination:=Range("A3:A3001"), Type:=xlFillDefault
Set ws = Nothing
Application.ScreenUpdating = True
End Sub