Sub ExtractAndCreateSheets()
Dim wbSource As Workbook
Dim wbNew As Workbook
Dim wsSource As Worksheet
Dim wsNew As Worksheet
Dim filePath As String
Dim newFileName As String
' ファイル選択ダイアログ
filePath = Application.GetOpenFilename("Excel Files (*.xlsx), *.xlsx", , "ファイルを選択")
If filePath = "False" Then Exit Sub ' キャンセルの場合は終了

' 選択したファイルを開く
Set wbSource = Workbooks.Open(filePath)
Set wsSource = wbSource.Sheets(1) ' 1シート目を対象にする

' 新しいワークブックを作成してオリジナルシートをコピー
Set wbNew = Workbooks.Add
wsSource.Copy Before:=wbNew.Sheets(1)
wbNew.Sheets(1).Name = "Original"

' シート作成用の列情報を設定
Dim sheetInfo As Variant
sheetInfo = Array( _
    Array("P_Story", Array("serial", "age", "ageband", "sex", "Story", "ADD_Story")), _
    Array("P_Likes", Array("serial", "age", "ageband", "sex", "Likes")), _
    Array("P_Dislikes", Array("serial", "age", "ageband", "sex", "Dislikes")), _
    Array("P_Impression", Array("serial", "age", "ageband", "sex", "Impression", "ADD_Impression")) _
)

' シートの作成
Dim i As Integer, j As Integer
Dim colIndexes As Collection
Dim colName As String

For i = LBound(sheetInfo) To UBound(sheetInfo)
    ' 抽出シートの作成
    Set wsNew = wbNew.Sheets.Add(After:=wbNew.Sheets(wbNew.Sheets.Count))
    wsNew.Name = sheetInfo(i)(0)
    
    ' 列インデックスを特定してデータをコピー
    Set colIndexes = New Collection
    For j = LBound(sheetInfo(i)(1)) To UBound(sheetInfo(i)(1))
        colName = sheetInfo(i)(1)(j)
        On Error Resume Next
        colIndexes.Add wsSource.Rows(1).Find(colName, LookAt:=xlWhole).Column
        On Error GoTo 0
    Next j

    ' データをコピー
    For j = 1 To colIndexes.Count
        wsSource.Columns(colIndexes(j)).Copy Destination:=wsNew.Columns(j)
    Next j
Next i

' 新しいファイル名を指定して保存
newFileName = Left(filePath, InStrRev(filePath, ".") - 1) & "_new.xlsx"
wbNew.SaveAs Filename:=newFileName, FileFormat:=xlOpenXMLWorkbook

' 元のファイルを閉じる
wbSource.Close False

MsgBox "処理が完了しました。" & vbCrLf & "保存先: " & newFileName, vbInformation
End Sub