VBA 複数CSVファイル読込 対象データのみ書込

プログラム

仕事で単純作業はVBAで自動化していますが、
客先から持ち出せないので、昔作ったやつを
ベースにしたいなーということはよくあります。

というわけでブログにため込んでいこうと思います。
これなら結構な確率で仕事先でも見れるんじゃないかと思っています。

VBA 複数CSVファイル読込 対象データのみ書込

csv_read:
 メインモジュールです。
 CSVファイルの読込、エクセルへのデータ出力を実施しています。

Sub csv_read()
'読込行&列指定
    Dim buf As Variant
    Dim Fnames As Variant
    Dim fn As Variant
    Dim FNo As Integer
    Dim TextLine As String
    Dim Key As Variant
    Dim TargetColumn As Variant
    
    Const RowMax As Long = 99
    Const ColMax As Long = 29
    flg = False
    
    ReDim Outline(RowMax, ColMax)
    
    Application.ScreenUpdating = False ' 描画を停止する
    
    Call GetKey(Key, TargetColumn)
    
    Fnames = Application.GetOpenFilename _
        ("CSVFile (*.csv), *.csv", 1, "ファイルインポート", , True)
    If VarType(Fnames) = vbBoolean Then Exit Sub

    For Each fn In Fnames
        FNo = FreeFile(0)
        Open fn For Input As #FNo
    
        Do While Not EOF(FNo)
            Line Input #FNo, TextLine
            buf = Split(TextLine, ",")
            '対象データを格納
            Call DataSet(Key, TargetColumn, buf, Outline, ColMax)
        Loop
    Close #FNo
    Next fn
    
    Application.ScreenUpdating = True  ' 描画を再開する
    
    '2シート目を選択:【前提】2シート目にCSVの内容を出力
    Worksheets(2).Select
    Range("A1").Resize(100, 30) = Outline   '1回だけ代入
    
End Sub

DataSet:
 指定したキーワード行の対象データを配列に格納してます。

Public Function DataSet(ByVal Key As Variant, ByVal TargetColumn As Variant, ByVal buf As Variant, ByRef Outline As Variant, ByVal ColMax As Long)

    Dim i As Long
    Dim j As Long
    Dim k As Long
    Dim flg As Boolean
    
    '対象キーワードの値を配列に格納
    For i = 1 To UBound(Key)
        If buf(0) = Key(i, 1) Then
            For j = 0 To UBound(Outline)
                If Outline(j, 0) = "" Then
                    Outline(j, 0) = Key(i, 1)
                    Outline(j, 1) = "'" & buf(TargetColumn)
                    flg = True
                    Exit For
                End If
                If Outline(j, 0) = Key(i, 1) Then
                    For k = 1 To ColMax
                       If Outline(j, k) = "" Then
                            Outline(j, k) = "'" & buf(TargetColumn)
                            flg = True
                            Exit For
                        End If
                    Next k
                End If
                If flg = True Then
                    flg = False
                    Exit For
                End If
            Next j
            If flg = True Then
                flg = False
                Exit For
            End If
        End If
    Next i
End Function

GetKey:
 1シート目に記入した対象キーワードと対象データ列を取得します。
 この関数単体では複数列の値を取得できますが、
 対象データ列は1列を前提にメインモジュールは処理をしています。

Public Function GetKey(ByRef SearchKey As Variant, ByRef column As Variant)

    '1シート目を選択:【前提】1シート目のA列に検索キーを書く
    Worksheets(1).Select
    'A列の検索キーを取得(A1は除く)
    SearchKey = Range("A2", Cells(Rows.Count, 1).End(xlUp)).Value
    'B列の対象データ列を取得(B1は除く)
    column = Range("B2", Cells(Rows.Count, 2).End(xlUp)).Value

End Function

使い方

まずシート1のA列に検索文字列、
B列にCSVファイルのデータを取得したい列を記載します。
列と記載しているのはCSVファイルをエクセルで開いたときに
イメージしやすいからで、取得したいデータが対象行の何番目か
考えて貰えればと思います。

VBAでcsv_readを実行。
対象CSVファイルを選択。
複数ファイルある場合は複数選択して開くをクリック。

実行結果イメージはこんな感じです。
前提として1データ目がキーになっている
CSVファイルをインプットにしています。
3データ目が取得したいデータ。
キーごとにデータを出力します。

今回はネットで調べていてもやりたいことずばりのものは出てこなかったので
あまり一般的にやりたいことではないかもしれませんね。

そのまま使えるものというよりは細かくモジュール化していって
何か作りたいときに、ベース部分はパーツを組み合わせるだけで
いいようなものを残していきたいと思います。

といいつつ1モジュールがそこそこ長かったりしますが、
おいおい改善していきたいと思います。