VBAを使ってCSVファイルから特定の行を抽出する
大量のCSVファイルと格闘する機会があった。しかも特定の文字列だけを抽出したいとのこと。。こんながっつり作業は久しぶり。力技でやろうかと考えたが、あまりのCSVファイルの数に挫折。自動化を考えることに( ﾟДﾟ)
CSVのファイルの数は多いが、幸いファイルサイズはさほど大きくなかった。そこでVBAで力技でやることに。ググってもいい感じの情報がサクッと見つからなかったので、将来CSVファイルと格闘する人のためにイケてないソースコードを公開する。
☆注意点☆
CSVのファイルサイズが大きいと動かないので要注意。なぜなら、考えるのがめんどくさく、ファイルオープンしてFINDしているからである。
[CSVファイルから特定の文字列が含まれる行を抽出するマクロ]
＜準備１＞
新規にxlsmファイルを作成。シートは以下二つを用意。
[検索値シート]
C1セルに”検索したいCSVファイル”が格納されているフォルダパスを入力
A列の2行目以降に検索、抽出したい文字列を記載。
サンプルのコードは完全一致。一行変えれば部分一致もできる。
マクロのボタンは、適当に配置。
[検索結果シート]
検索、抽出結果が出力されるシート
一行目のラベル(A~D列)は自分で事前に入力。二行目以降は自動で出力される。
- A~D列に、どのファイルをどの文字列で検索して、どこにあったかを出力
- F列以降は、検索対象文字列が含まれる行をそのまま出力
上記だと、”test"と"sampleって文字列を検索し、該当する行を抽出している。
検索対象のCSVファイルは以下の感じ。
↓test.csv↓
＜準備2＞
以下のコードを貼り付けて、search関数を実行すればおしまい。コメントの場所と改行をいじっているので動かなかったらごめんなさい。
ちなみに拡張子を変えれば、CSVファイルじゃなくてエクセルファイルでも検索、抽出はできる。(想定)
↓ここから
Sub search()
Application.ScreenUpdating = False 'ちらつき防止
Dim targetSheet As Worksheet'検索値があるシート
Dim outputSheet As Worksheet'検索結果を出力するシート
Dim outputSheetRowAddress As Integer ’検索結果を出力するシート
outputSheetRowAddress = 2
Dim searchSheet As Worksheet'対象データがあるシート
Set targetSheet = Worksheets(1)
Set outputSheet = Worksheets(2)
Dim File_Name As String
Dim fl_name As String
Dim DIR_PATH As String
Dim SourcePath As String
Dim Opnbook As Workbook
SourcePath = "C1"'検索元ファイルのPath定義
'検索元データの格納チェック
DIR_PATH = targetSheet.Range(SourcePath).Value
fl_name = Dir(DIR_PATH & "\*.csv*") 'ここ円マークです
If fl_name = "" Then
MsgBox "CSVファイルがありません。"
Exit Sub
End If
'指定フォルダにあるCSVファイルの数だけ検索を実行
Do
Dim sheetCount As Integer
Set Opnbook = Workbooks.Open(DIR_PATH & "\" & fl_name) 'ここ円マークです
sheetCount = Opnbook.Worksheets.Count
If sheetCount = 0 Then
MsgBox "シートがないへんなファイルです" & fl_name
Exit Sub
End If
'シートの数だけ検索を繰り返す。CSVファイルなので基本1つのはず。
For i = 1 To sheetCount
Dim row As Integer'検索値の最終行取得
row = targetSheet.Cells(targetSheet.Rows.Count, 1).End(xlUp).row
For k = 2 To row
Dim foundCell As Range'検索結果のセル
Dim searchCell As Range'検索値のセル
Set searchCell = targetSheet.Cells(k, 1)
If Not searchCell = "" Then'検索値が空白でなければ検索実行
Set foundCell = Opnbook.Worksheets(i).Cells.Find(searchCell, LookAt:=xlWhole, SearchOrder:=xlByColumns)'検索結果取得
If Not foundCell Is Nothing Then'検索値があったら以下実行
Dim FirstCell As Range
Set FirstCell = foundCell
Do
'検索値に一致した行をコピー
Opnbook.Worksheets(i).Rows(foundCell.row).Copy
'検索結果出力シートに張り付け
outputSheet.Rows(outputSheetRowAddress).PasteSpecial (xlPasteAll)
'空のセルを追加するためにA1を選択
outputSheet.Activate
outputSheet.Range("A1").Select
'ファイル名、シート名、行番号を入れるためにセルをずらす
outputSheet.Range(Cells(outputSheetRowAddress, 1), Cells(outputSheetRowAddress, 5)).Insert xlShiftToRight
outputSheet.Cells(outputSheetRowAddress, 1).Value = fl_name
outputSheet.Cells(outputSheetRowAddress, 2).Value = Opnbook.Worksheets(i).Name
outputSheet.Cells(outputSheetRowAddress, 3).Value = foundCell.Address
outputSheet.Cells(outputSheetRowAddress, 4).Value = searchCell.Value
'検索結果出力シートの貼り付け先の行を更新
outputSheetRowAddress = outputSheetRowAddress + 1
'次を検索
Set foundCell = Opnbook.Worksheets(i).Cells.FindNext(foundCell)
'次の検索結果が最初と同じかか存在しなかったら、次の検索処理へ
If foundCell.Address = FirstCell.Address Then
Exit Do
ElseIf foundCell Is Nothing Then
Exit Do
End If
Loop
End If
End If
Next
Next
'開いたファイルを閉じる
Application.DisplayAlerts = False
Opnbook.Close
fl_name = Dir
Loop Until fl_name = ""
'最後に罫線設定をして、オートフィルタ設定しておしまい
tmp = outputSheet.Range("A1").End(xlDown).row
outputSheet.Range("A1:D" & Format(tmp)).Borders.LineStyle = xlContinuous
outputSheet.Range("A2:D" & Format(tmp)).Interior.ColorIndex = 15
If outputSheet.AutoFilterMode = False Then
outputSheet.Range("A1:D1").AutoFilter
End If
End Sub
↑ここまで
久々にコードを書いて思ったのは、もう現場戻れないな。。。
変数の名前とかめんどくさくて”tmp1"とか"temp3"とか一回動いたら、そのまま放置してしれっとリリースすると思う。
