Option Explicit

Sub MakeFlashcards_FromThisExcel_Alternate_SameFolder()
    '―― PowerPoint定数（Late Binding用：数値で定義）
    Const ppLayoutBlank As Long = 12
    Const msoTextOrientationHorizontal As Long = 1
    Const ppAlignLeft As Long = 1
    Const ppSaveAsOpenXMLPresentation As Long = 24

    Dim ws As Worksheet
    Dim last As Long, i As Long
    Dim flagVal As Variant, redText As String, blueText As String
    Dim reds() As String, blues() As String
    Dim redCount As Long, blueCount As Long, r As Long, b As Long

    Dim pptApp As Object, pptPres As Object
    Dim sld As Object, t As Object
    Dim savePath As String, ts As String
    Dim basePath As String

    On Error GoTo EH

    ' 1) Excelの保存場所を取得
    basePath = ThisWorkbook.Path
    If Len(basePath) = 0 Then
        MsgBox "このブックがまだ保存されていません。いったん保存してから実行してください。", vbExclamation
        Exit Sub
    End If

    ' 2) 対象シート（今開いてるシート）
    Set ws = ActiveSheet

    ' 3) データ読み込み（見出し行=1、FLAG=1のみ収集）
    last = ws.Cells(ws.Rows.Count, 3).End(xlUp).Row ' C列の最終行
    redCount = 0: blueCount = 0

    For i = 2 To last
        flagVal = ws.Cells(i, 2).Value                  ' B=FLAG
        redText = Trim$(CStr(ws.Cells(i, 3).Value))     ' C=赤（用語）
        blueText = Trim$(CStr(ws.Cells(i, 4).Value))    ' D=青（説明）
        If flagVal = 1 Then
            If Len(redText) > 0 Then
                redCount = redCount + 1
                ReDim Preserve reds(1 To redCount)
                reds(redCount) = redText
            End If
            If Len(blueText) > 0 Then
                blueCount = blueCount + 1
                ReDim Preserve blues(1 To blueCount)
                blues(blueCount) = blueText
            End If
        End If
    Next i

    If redCount = 0 And blueCount = 0 Then
        MsgBox "FLAG=1 の有効データがありません。", vbExclamation
        Exit Sub
    End If

    ' 4) 新規 PowerPoint を作成
    Set pptApp = CreateObject("PowerPoint.Application")
    pptApp.Visible = True
    Set pptPres = pptApp.Presentations.Add

    ' 5) 赤・青を交互にスライド追加（左寄せ＆広いテキストエリア）
    r = 1: b = 1
    Do While r <= redCount Or b <= blueCount
        If r <= redCount Then
            Set sld = pptPres.Slides.Add(pptPres.Slides.Count + 1, ppLayoutBlank)
            Set t = sld.Shapes.AddTextbox(msoTextOrientationHorizontal, 50, 150, 820, 300)
            With t.TextFrame.TextRange
                .Text = reds(r)
                .Font.Size = 48
                .Font.Color.RGB = RGB(255, 0, 0)
                .ParagraphFormat.Alignment = ppAlignLeft
            End With
            r = r + 1
        End If

        If b <= blueCount Then
            Set sld = pptPres.Slides.Add(pptPres.Slides.Count + 1, ppLayoutBlank)
            Set t = sld.Shapes.AddTextbox(msoTextOrientationHorizontal, 50, 150, 820, 340)
            With t.TextFrame.TextRange
                .Text = blues(b)
                .Font.Size = 36
                .Font.Color.RGB = RGB(0, 0, 255)
                .ParagraphFormat.Alignment = ppAlignLeft
            End With
            b = b + 1
        End If
    Loop

    ' 6) 同じフォルダに自動保存（PPTX強制）
    ts = Format(Now, "yyyymmdd_HhNnSs")
    savePath = basePath & "\フラッシュカード版_交互_" & ts & ".pptx"
    pptPres.SaveAs savePath, ppSaveAsOpenXMLPresentation

    MsgBox "フラッシュカード作成完了！" & vbCrLf & savePath, vbInformation
    Exit Sub

EH:
    MsgBox "エラー: " & Err.Number & " - " & Err.Description, vbExclamation
End Sub