PowerPointの赤文字・青文字を自動でExcelに抽出するVBAマクロ

'========================================
' PowerPoint → Excel
' 赤と青を別々に収集し、Excelで
' C列(赤)・D列(青)を各々2行目から上詰め
' A列Noは赤の通し番号のみ記入（青は空欄）
'========================================
Option Explicit

'--- 色ヘルパー
Private Function RFromRGB(col As Long) As Long: RFromRGB = (col And &HFF&): End Function
Private Function GFromRGB(col As Long) As Long: GFromRGB = ((col \ &H100&) And &HFF&): End Function
Private Function BFromRGB(col As Long) As Long: BFromRGB = ((col \ &H10000) And &HFF&): End Function

'--- 判定（完全一致も緩めもOK）
Private Function IsRedColor(col As Long) As Boolean
    Dim r As Long, g As Long, b As Long
    r = RFromRGB(col): g = GFromRGB(col): b = BFromRGB(col)
    If col = RGB(255, 0, 0) Then IsRedColor = True: Exit Function
    IsRedColor = (r >= 180 And r > g + 20 And r > b + 20)
End Function

Private Function IsBlueColor(col As Long) As Boolean
    Dim r As Long, g As Long, b As Long
    r = RFromRGB(col): g = GFromRGB(col): b = BFromRGB(col)
    If col = RGB(0, 0, 255) Then IsBlueColor = True: Exit Function
    IsBlueColor = (b >= 180 And b > g + 20 And b > r + 20)
End Function

'--- 整形
Private Function CleanText(ByVal s As String) As String
    s = Replace(s, vbCrLf, " ")
    s = Replace(s, vbCr, " ")
    s = Replace(s, vbLf, " ")
    s = Replace(s, vbTab, " ")
    CleanText = Trim$(s)
End Function

'--- 安全にRGB取得（取れない時は -1）
Private Function SafeRGB_Char(ByVal tr As TextRange) As Long
    On Error Resume Next
    SafeRGB_Char = tr.Font.Color.RGB
    If Err.Number <> 0 Then SafeRGB_Char = -1
    On Error GoTo 0
End Function

'--- 色クラス：0=その他/無色, 1=赤, 2=青
Private Function ColorClass(ByVal col As Long) As Integer
    If col = -1 Then
        ColorClass = 0
    ElseIf IsRedColor(col) Then
        ColorClass = 1
    ElseIf IsBlueColor(col) Then
        ColorClass = 2
    Else
        ColorClass = 0
    End If
End Function

'--- 段落を走査し、同色連続ランを抽出して配列に追加
Private Sub CollectColorRuns(ByVal para As TextRange, ByRef reds As Collection, ByRef blues As Collection)
    Dim i As Long, ch As TextRange, col As Long
    Dim curClass As Integer, prevClass As Integer
    Dim buf As String

    prevClass = 0
    buf = ""

    For i = 1 To para.Length
        Set ch = para.Characters(i, 1)
        col = SafeRGB_Char(ch)
        curClass = ColorClass(col)

        If curClass = prevClass Then
            If curClass <> 0 Then buf = buf & ch.Text
        Else
            If prevClass = 1 And Len(CleanText(buf)) > 0 Then
                reds.Add CleanText(buf)
            ElseIf prevClass = 2 And Len(CleanText(buf)) > 0 Then
                blues.Add CleanText(buf)
            End If
            buf = ""
            If curClass <> 0 Then buf = ch.Text
        End If
        prevClass = curClass
    Next i

    ' 残りを追加
    If prevClass = 1 And Len(CleanText(buf)) > 0 Then
        reds.Add CleanText(buf)
    ElseIf prevClass = 2 And Len(CleanText(buf)) > 0 Then
        blues.Add CleanText(buf)
    End If
End Sub

'--- 図形を再帰的に走査して収集
Private Sub CollectFromShape(ByVal shp As Shape, ByRef reds As Collection, ByRef blues As Collection)
    Dim i As Long, j As Long, p As Long
    Dim tr As TextRange

    On Error Resume Next

    If shp.Type = msoGroup Then
        For i = 1 To shp.GroupItems.Count
            CollectFromShape shp.GroupItems(i), reds, blues
        Next i
        Exit Sub
    End If

    If shp.HasTable Then
        For i = 1 To shp.Table.Rows.Count
            For j = 1 To shp.Table.Columns.Count
                If shp.Table.Cell(i, j).Shape.HasTextFrame Then
                    If shp.Table.Cell(i, j).Shape.TextFrame.HasText Then
                        Set tr = shp.Table.Cell(i, j).Shape.TextFrame.TextRange
                        For p = 1 To tr.Paragraphs.Count
                            CollectColorRuns tr.Paragraphs(p), reds, blues
                        Next p
                    End If
                End If
            Next j
        Next i
        Exit Sub
    End If

    If shp.HasTextFrame Then
        If shp.TextFrame.HasText Then
            Set tr = shp.TextFrame.TextRange
            For p = 1 To tr.Paragraphs.Count
                CollectColorRuns tr.Paragraphs(p), reds, blues
            Next p
        End If
    End If
End Sub

'--- メイン：赤/青を別々に書き出し
Public Sub ExportRedBlue_SeparateColumns()
    Dim xlApp As Object, xlWb As Object, ws As Object
    Dim sld As Slide, shp As Shape
    Dim reds As New Collection, blues As New Collection
    Dim i As Long
    Dim rowR As Long, rowB As Long
    Dim savePath As String, baseName As String

    ' 収集
    For Each sld In ActivePresentation.Slides
        For Each shp In sld.Shapes
            CollectFromShape shp, reds, blues
        Next shp
    Next sld

    ' Excel準備
    Set xlApp = CreateObject("Excel.Application")
    xlApp.Visible = True
    Set xlWb = xlApp.Workbooks.Add
    Set ws = xlWb.Worksheets(1)

    ws.Cells(1, 1).Value = "No"                 ' 赤の通し番号
    ws.Cells(1, 2).Value = "FLAG"
    ws.Cells(1, 3).Value = "赤文字(C列)"
    ws.Cells(1, 4).Value = "青文字(D列)"
    ws.Range("A1:D1").Font.Bold = True

    rowR = 2: rowB = 2

    ' 赤を書き出し（A=No, B=FLAG, C=赤）
    For i = 1 To reds.Count
        ws.Cells(rowR, 1).Value = i          ' 赤のNo
        ws.Cells(rowR, 2).Value = ""         ' FLAG（手入力用）
        ws.Cells(rowR, 3).Value = reds(i)    ' 赤
        rowR = rowR + 1
    Next i

    ' 青を書き出し（Dのみ埋める／AとBは空欄のまま）
    For i = 1 To blues.Count
        ws.Cells(rowB, 4).Value = blues(i)   ' 青
        rowB = rowB + 1
    Next i

    ws.Columns("A:D").AutoFit

    baseName = Left$(ActivePresentation.Name, InStrRev(ActivePresentation.Name, ".") - 1)
    savePath = ActivePresentation.Path & "\" & baseName & "_赤青_独立列.xlsx"
    xlWb.SaveAs savePath

    MsgBox "出力完了！" & vbCrLf & _
           "赤: " & (reds.Count) & " 件, 青: " & (blues.Count) & " 件" & vbCrLf & _
           "保存先: " & savePath, vbInformation
End Sub