Sub Import5ASheets()
    Dim ws As Worksheet
    Dim sourceWb As Workbook
    Dim targetWb As Workbook
    Dim sourceSheet As Worksheet
    Dim newSheet As Worksheet
    Dim filePath As String
    Dim i As Long
    Dim lastRow As Long
    Dim counter As Long
    Dim sheetName As String
    
    ' 現在のワークブックを対象ワークブックとして設定
    Set targetWb = ThisWorkbook
    Set ws = targetWb.Sheets("Sheet1")
    
    ' B列の最終行を取得
    lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
    
    ' カウンターを初期化
    counter = 1
    
    ' エラーハンドリングの設定
    On Error GoTo ErrorHandler
    
    ' B列2行目以降のファイルパスを順次処理
    For i = 2 To lastRow
        filePath = ws.Cells(i, "B").Value
        
        ' ファイルパスが空でない場合のみ処理
        If filePath <> "" Then
            ' ファイルが存在するかチェック
            If Dir(filePath) <> "" Then
                ' ファイルを開く
                Set sourceWb = Workbooks.Open(filePath)
                
                ' 「5A_フロー」シートが存在するかチェック
                If SheetExists(sourceWb, "5A_フロー") Then
                    Set sourceSheet = sourceWb.Sheets("5A_フロー")
                    
                    ' シートをコピー
                    sourceSheet.Copy After:=targetWb.Sheets(targetWb.Sheets.Count)
                    
                    ' 新しいシートを取得
                    Set newSheet = targetWb.Sheets(targetWb.Sheets.Count)
                    
                    ' シート名を変更（連番付き）
                    sheetName = "5A_" & Format(counter, "00")
                    newSheet.Name = sheetName
                    
                    counter = counter + 1
                    
                    Debug.Print "シート追加完了: " & sheetName & " (元ファイル: " & sourceWb.Name & ")"
                Else
                    Debug.Print "「5A_フロー」シートが見つかりません: " & sourceWb.Name
                End If
                
                ' ソースワークブックを閉じる（保存しない）
                sourceWb.Close SaveChanges:=False
                Set sourceWb = Nothing
            Else
                Debug.Print "ファイルが見つかりません: " & filePath
            End If
        End If
    Next i
    
    MsgBox "処理完了しました。" & (counter - 1) & "個のシートを追加しました。"
    Exit Sub
    
ErrorHandler:
    ' エラーが発生した場合の処理
    If Not sourceWb Is Nothing Then
        sourceWb.Close SaveChanges:=False
        Set sourceWb = Nothing
    End If
    
    MsgBox "エラーが発生しました: " & Err.Description & vbCrLf & _
           "ファイル: " & filePath & vbCrLf & _
           "行: " & i
    
End Sub

' シートの存在をチェックする関数
Function SheetExists(wb As Workbook, sheetName As String) As Boolean
    Dim ws As Worksheet
    SheetExists = False
    
    For Each ws In wb.Worksheets
        If ws.Name = sheetName Then
            SheetExists = True
            Exit For
        End If
    Next ws
End Function

' 手動実行用のサブプロシージャ（オプション）
Sub ExecuteImport()
    Call Import5ASheets
End Sub


'シートの内容取得
Sub ReadExcelWithOleDB()
    Dim cn As Object
    Dim rs As Object
    Dim strSQL As String
    Dim filePath As String
    
    filePath = "C:\YourFolder\YourFile.xlsx"
    
    Set cn = CreateObject("ADODB.Connection")
    Set rs = CreateObject("ADODB.Recordset")
    
    ' Excel 2007以降（.xlsx）の場合
    cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
            "Data Source=" & filePath & ";" & _
            "Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
    
    ' Sheet1の全データ取得例
    strSQL = "SELECT * FROM [Sheet1$]"
    
    rs.Open strSQL, cn
    
    ' データ出力テスト
    Do Until rs.EOF
        Debug.Print rs.Fields(0).Value
        rs.MoveNext
    Loop
    
    rs.Close
    cn.Close
End Sub

'シート名取得

Sub GetSheetNamesWithOleDB()
    Dim cn As Object
    Dim rs As Object
    Dim filePath As String
    
    filePath = "C:\YourFolder\YourFile.xlsx"
    
    Set cn = CreateObject("ADODB.Connection")
    Set rs = CreateObject("ADODB.Recordset")
    
    cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
            "Data Source=" & filePath & ";" & _
            "Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
    
    ' シート名取得
    Set rs = cn.OpenSchema(20) ' 20 = adSchemaTables
    
    Do Until rs.EOF
        Debug.Print rs.Fields("TABLE_NAME").Value
        rs.MoveNext
    Loop
    
    rs.Close
    cn.Close
End Sub