2020/06/18 (更新日: 2021/03/10)

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

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