Option Explicit
 
Public Sub CSV取り込み()
    Const Folder As String = "D:\goo\data9"
    Dim dicT As Object
    Dim ws As Worksheet
 
    Dim path As String
    Dim sline As String
    Dim head() As String
    Dim elms() As String
    Dim ConV() As Long
    Dim i As Long
    Dim wcol As Long
    Dim maxcol As Long
    Dim key As String
    Dim wrow As Long: wrow = 2
    Set dicT = CreateObject("Scripting.Dictionary") ' 連想配列の定義
    Set ws = Worksheets("Sheet1")
    maxcol = ws.Cells(1, Columns.count).End(xlToLeft).Column   '1行目の最終列を求める
    'Excelのキーを記憶
    For wcol = 1 To maxcol
        key = ws.Cells(1, wcol).Value
        If key <> "" Then
            dicT(key) = wcol
        End If
    Next
    '2行目以降をクリア
    ws.Rows("2:" & Rows.count).ClearContents
    'CSVオープン
    path = Folder & "\" & "test.csv"
    Open path For Input As #1
    '1行目を読み込む
    Line Input #1, sline
    'キー変換テーブルを作成
    head = Split(sline, ",")
    ReDim ConV(UBound(head))
    For i = 0 To UBound(head)
        key = head(i)
        ConV(i) = 0
        If key <> "" And dicT.exists(key) = True Then
            ConV(i) = dicT(key)
        End If
    Next
    '2行目以降を読み込む
    Do Until EOF(1)
        Line Input #1, sline
        elms = Split(sline, ",")
        '各列を処理する
        For i = 0 To UBound(elms)
            'ヘッダの列数以内を処理
            If i <= UBound(head) Then
                '変換対象のキーがあれば処理する
                If ConV(i) > 0 Then
                    wcol = ConV(i)
                    ws.Cells(wrow, wcol).Value = elms(i)
                End If
            End If
        Next
        wrow = wrow + 1
    Loop
    Close #1
    MsgBox ("完了")
End Sub
 

T3B0aW9uIEV4cGxpY2l0CgpQdWJsaWMgU3ViIENTVuWPluOCiui+vOOBvygpCiAgICBDb25zdCBGb2xkZXIgQXMgU3RyaW5nID0gIkQ6XGdvb1xkYXRhOSIKICAgIERpbSBkaWNUIEFzIE9iamVjdAogICAgRGltIHdzIEFzIFdvcmtzaGVldAogICAgCiAgICBEaW0gcGF0aCBBcyBTdHJpbmcKICAgIERpbSBzbGluZSBBcyBTdHJpbmcKICAgIERpbSBoZWFkKCkgQXMgU3RyaW5nCiAgICBEaW0gZWxtcygpIEFzIFN0cmluZwogICAgRGltIENvblYoKSBBcyBMb25nCiAgICBEaW0gaSBBcyBMb25nCiAgICBEaW0gd2NvbCBBcyBMb25nCiAgICBEaW0gbWF4Y29sIEFzIExvbmcKICAgIERpbSBrZXkgQXMgU3RyaW5nCiAgICBEaW0gd3JvdyBBcyBMb25nOiB3cm93ID0gMgogICAgU2V0IGRpY1QgPSBDcmVhdGVPYmplY3QoIlNjcmlwdGluZy5EaWN0aW9uYXJ5IikgJyDpgKPmg7PphY3liJfjga7lrprnvqkKICAgIFNldCB3cyA9IFdvcmtzaGVldHMoIlNoZWV0MSIpCiAgICBtYXhjb2wgPSB3cy5DZWxscygxLCBDb2x1bW5zLmNvdW50KS5FbmQoeGxUb0xlZnQpLkNvbHVtbiAgICcx6KGM55uu44Gu5pyA57WC5YiX44KS5rGC44KB44KLCiAgICAnRXhjZWzjga7jgq3jg7zjgpLoqJjmhrYKICAgIEZvciB3Y29sID0gMSBUbyBtYXhjb2wKICAgICAgICBrZXkgPSB3cy5DZWxscygxLCB3Y29sKS5WYWx1ZQogICAgICAgIElmIGtleSA8PiAiIiBUaGVuCiAgICAgICAgICAgIGRpY1Qoa2V5KSA9IHdjb2wKICAgICAgICBFbmQgSWYKICAgIE5leHQKICAgICcy6KGM55uu5Lul6ZmN44KS44Kv44Oq44KiCiAgICB3cy5Sb3dzKCIyOiIgJiBSb3dzLmNvdW50KS5DbGVhckNvbnRlbnRzCiAgICAnQ1NW44Kq44O844OX44OzCiAgICBwYXRoID0gRm9sZGVyICYgIlwiICYgInRlc3QuY3N2IgogICAgT3BlbiBwYXRoIEZvciBJbnB1dCBBcyAjMQogICAgJzHooYznm67jgpLoqq3jgb/ovrzjgoAKICAgIExpbmUgSW5wdXQgIzEsIHNsaW5lCiAgICAn44Kt44O85aSJ5o+b44OG44O844OW44Or44KS5L2c5oiQCiAgICBoZWFkID0gU3BsaXQoc2xpbmUsICIsIikKICAgIFJlRGltIENvblYoVUJvdW5kKGhlYWQpKQogICAgRm9yIGkgPSAwIFRvIFVCb3VuZChoZWFkKQogICAgICAgIGtleSA9IGhlYWQoaSkKICAgICAgICBDb25WKGkpID0gMAogICAgICAgIElmIGtleSA8PiAiIiBBbmQgZGljVC5leGlzdHMoa2V5KSA9IFRydWUgVGhlbgogICAgICAgICAgICBDb25WKGkpID0gZGljVChrZXkpCiAgICAgICAgRW5kIElmCiAgICBOZXh0CiAgICAnMuihjOebruS7pemZjeOCkuiqreOBv+i+vOOCgAogICAgRG8gVW50aWwgRU9GKDEpCiAgICAgICAgTGluZSBJbnB1dCAjMSwgc2xpbmUKICAgICAgICBlbG1zID0gU3BsaXQoc2xpbmUsICIsIikKICAgICAgICAn5ZCE5YiX44KS5Yem55CG44GZ44KLCiAgICAgICAgRm9yIGkgPSAwIFRvIFVCb3VuZChlbG1zKQogICAgICAgICAgICAn44OY44OD44OA44Gu5YiX5pWw5Lul5YaF44KS5Yem55CGCiAgICAgICAgICAgIElmIGkgPD0gVUJvdW5kKGhlYWQpIFRoZW4KICAgICAgICAgICAgICAgICflpInmj5vlr77osaHjga7jgq3jg7zjgYzjgYLjgozjgbDlh6bnkIbjgZnjgosKICAgICAgICAgICAgICAgIElmIENvblYoaSkgPiAwIFRoZW4KICAgICAgICAgICAgICAgICAgICB3Y29sID0gQ29uVihpKQogICAgICAgICAgICAgICAgICAgIHdzLkNlbGxzKHdyb3csIHdjb2wpLlZhbHVlID0gZWxtcyhpKQogICAgICAgICAgICAgICAgRW5kIElmCiAgICAgICAgICAgIEVuZCBJZgogICAgICAgIE5leHQKICAgICAgICB3cm93ID0gd3JvdyArIDEKICAgIExvb3AKICAgIENsb3NlICMxCiAgICBNc2dCb3ggKCLlrozkuoYiKQpFbmQgU3ViCg==