VBAでフォルダ内のCSVファイルを全部新しいSheetとして追加するコード

投稿日：2020年12月27日

VBAでフォルダ内のCSVファイルを全部新しいSheetとして追加するコードを書きました。
月ごとのCSVファイルを一つのワークブックに追加したいときに便利です。

Sub フォルダ内のCSVファイルを全部開く()

    'フォルダ選択
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = True Then
            Dim FSO As Object
            Dim f As Variant
            Set FSO = CreateObject("Scripting.FileSystemObject")
            For Each f In FSO.GetFolder(.SelectedItems(1)).Files
                If LCase(FSO.GetExtensionName(f.Name)) = "csv" Then
                    新しいシートでCSVファイルを開く f.Path, FSO.GetBaseName(f.Name)
                End If
            Next f
        End If
    End With

End Sub


Private Sub 新しいシートでCSVファイルを開く(sPath As String, sSheetName As String)

    Worksheets.Add after:=Worksheets(Worksheets.Count)

    Dim ws As Worksheet
    Set ws = ActiveSheet
    
    ws.Name = sSheetName

    Dim qt As QueryTable
    Set qt = ws.QueryTables.Add(Connection:="TEXT;" & sPath, Destination:=ws.Range("A1"))
    With qt
        .TextFilePlatform = 932
        .TextFileParseType = xlDelimited
        .TextFileCommaDelimiter = True
        .RefreshStyle = xlOverwriteCells
        .Refresh
        .Delete
    End With

End Sub

Sub フォルダ内のCSVファイルを全部開く()

'フォルダ選択

With Application.FileDialog(msoFileDialogFolderPicker)

If .Show = True Then

Dim FSO As Object

Dim f As Variant

Set FSO = CreateObject("Scripting.FileSystemObject")

For Each f In FSO.GetFolder(.SelectedItems(1)).Files

If LCase(FSO.GetExtensionName(f.Name)) = "csv" Then

新しいシートでCSVファイルを開く f.Path, FSO.GetBaseName(f.Name)

End If

Next f

End If

End With

End Sub

Private Sub 新しいシートでCSVファイルを開く(sPath As String, sSheetName As String)

Worksheets.Add after:=Worksheets(Worksheets.Count)

Dim ws As Worksheet

Set ws = ActiveSheet

ws.Name = sSheetName

Dim qt As QueryTable

Set qt = ws.QueryTables.Add(Connection:="TEXT;" & sPath, Destination:=ws.Range("A1"))

With qt

.TextFilePlatform = 932

.TextFileParseType = xlDelimited

.TextFileCommaDelimiter = True

.RefreshStyle = xlOverwriteCells

.Refresh

.Delete

End With

End Sub