vba で まとめてcsv読み込み

大量のcsvを読み込んでExcel処理したかったので手動は面倒くさくてvbaに初挑戦したメモ。
OpenTextではなぜかセミコロン区切りのものをうまく読み込んでくれず、手動でやってるときはクエリを使っていたことを思い出しQueryTableを使用。

vba入門はこちらを、
color-chips.net

複数ファイルの読み込みはこちらを、
color-chips.net

QueryTableの使い方はこちらを
water2litter.net

参考にさせていただきました。

Sub QueryMultiCSVFiles()
    ' [[ 変数定義 ]]
    Dim varFileName As Variant
    Dim FileName As Variant
    Dim CSVWorkSheet As Worksheet
    Dim NewWorkSheet As Worksheet
    Dim SheetName As String
    Dim qt As QueryTable
    
   
    ' [[ 複数ファイルパス名を取得 ]]
    varFileName = Application.GetOpenFilename(FileFilter:="CSVファイル(*.csv),*.csv", Title:="CSVファイルの選択", MultiSelect:=True)
   
    ' [[ ファイルパス取得できなかったら ]]
    If IsArray(varFileName) = False Then
        Exit Sub
        MsgBox "Isarray Error"
    End If
 
    ' [[ ファイルパス取得できたら ]]
    For Each FileName In varFileName
        ' [[ ファイルパスからファイル名を取得 ]]
        SheetName = Dir(FileName)
        ' [[ ファイル名で新しいシート作成 ]]
        Set NewWorkSheet = CreateWorkSheet(SheetName)
        
        Set CSVWorkSheet = ActiveSheet
        Set qt = CSVWorkSheet.QueryTables.Add(Connection:="TEXT;" & FileName, Destination:=CSVWorkSheet.Range("A1"))
       
        With qt
            .TextFilePlatform = 932          ' 文字コードを指定
            .TextFileParseType = xlDelimited ' 区切り文字の形式
            .TextFileSemicolonDelimiter = True   ' カンマ区切り
            .RefreshStyle = xlOverwriteCells ' セルに上書き
            .Refresh
            .Delete                          ' CSV との接続を解除
        End With
    Next
   
End Sub


' [[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]
' [[                                                                            ]]
' [[ ワークシート名を指定したワークシートの作成                                 ]]
' [[                                                                            ]]
' [[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]
Function CreateWorkSheet(WorkSheetName As String) As Worksheet

    ' 変数定義
    Dim NewWorkSheet As Worksheet
    Dim WS As Worksheet
    
    Dim iCheckSameName As Integer
   
    ' ワークシートの作成
    ' ※一番最後に挿入
    Set NewWorkSheet = Worksheets.Add(After:=Worksheets(Worksheets.Count))
   
    ' 同じ名前ワークシートが無いか確認
    iCheckSameName = 0
    For Each WS In Sheets
        If WS.Name = WorkSheetName Then
            MsgBox "ワークシート名：" + WorkSheetName + " この名前は既に使われています。"
            iCheckSameName = 1
        End If
    Next
   
    '同じ名前のワークシートがなければ
    If iCheckSameName = 0 Then
        NewWorkSheet.Name = WorkSheetName
        Set CreateWorkSheet = NewWorkSheet
    End If
   
End Function