Excel VBAでCSVファイルを一括インポート：効率的なデータ統合手法

Sub ImportAllCSVFilesToNewWorkbook()
    Dim MyFolder As String
    Dim MyFile As String
    Dim newWb As Workbook
    Dim ws As Worksheet
    Dim sheetName As String
    Dim newFileName As String
    
    ' ユーザーに新しいファイル名を入力させる
    newFileName = InputBox("新しいExcelファイルの名前を入力してください（拡張子不要）:")
    If newFileName = "" Then Exit Sub ' キャンセルされたまたは何も入力されなかった場合は終了
    
    On Error GoTo ErrorHandler ' エラーハンドリング
    
    ' 現在のExcelファイルと同じフォルダのパスを取得
    If ThisWorkbook.Path = "" Then
        MsgBox "このワークブックはまだ保存されていません。先に保存してください。"
        Exit Sub
    End If
    
    MyFolder = ThisWorkbook.Path & "\"
    
    ' 新しいワークブックを作成
    Set newWb = Workbooks.Add
    
    ' 指定されたフォルダ内の最初のCSVファイルを見つける
    MyFile = Dir(MyFolder & "*.csv")
    
    Do While Len(MyFile) > 0
        ' ファイル名から拡張子を取り除いてワークシート名を作成
        sheetName = Left(MyFile, InStrRev(MyFile, ".") - 1)
        
        ' 名前に使用できない文字を取り除く（オプション）
        sheetName = Replace(sheetName, "\", "")
        sheetName = Replace(sheetName, "/", "")
        sheetName = Replace(sheetName, "?", "")
        sheetName = Replace(sheetName, "*", "")
        sheetName = Replace(sheetName, "[", "")
        sheetName = Replace(sheetName, "]", "")
        
        ' 31文字を超える場合は切り詰める（オプション）
        If Len(sheetName) > 31 Then
            sheetName = Left(sheetName, 31)
        End If
        
        ' 新しいワークシートを追加して名前を設定
        Set ws = newWb.Worksheets.Add
        ws.Name = sheetName
        
        ' CSVファイルを新しいワークシートにインポート
        With ws.QueryTables.Add(Connection:="TEXT;" & MyFolder & MyFile, Destination:=ws.Range("A1"))
            .TextFileParseType = xlDelimited
            .TextFileConsecutiveDelimiter = False
            .TextFileTabDelimiter = False
            .TextFileSemicolonDelimiter = False
            .TextFileCommaDelimiter = True
            .Refresh BackgroundQuery:=False
        End With
        
        ' 次のCSVファイルを見つける
        MyFile = Dir()
    Loop
    
    ' 新しいワークブックを保存
    newWb.SaveAs Filename:=MyFolder & newFileName & ".xlsx", FileFormat:=xlOpenXMLWorkbook
    
    Exit Sub
    
ErrorHandler: ' エラーハンドリング
    MsgBox "エラーが発生しました: " & Err.Description
End Sub

' MIT License
' Copyright (c) 2023 [ANJI]
'
' Permission is hereby granted, free of charge, to any person obtaining a copy
' of this software and associated documentation files (the "Software"), to deal
' in the Software without restriction, including without limitation the rights
' to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
' copies of the Software, and to permit persons to whom the Software is
' furnished to do so, subject to the following conditions:
'
' The above copyright notice and this permission notice shall be included in all
' copies or substantial portions of the Software.
'
' THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
' IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
' FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
' AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
' LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
' OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
' SOFTWARE.