Sub ExtractOverlappingShapesAndTextBoxes()
    Dim ws As Worksheet
    Dim shp As Shape
    Dim rect As Shape
    Dim txtBox As Shape
    Dim i As Integer, j As Integer
    Dim outputRow As Integer
    Dim rectangles As Collection
    Dim textBoxes As Collection
    Dim rectBounds As Object
    Dim txtBounds As Object
    Dim maxCol As Double
    
    ' シート『5Aフロー』を取得
    On Error Resume Next
    Set ws = ThisWorkbook.Worksheets("5Aフロー")
    On Error GoTo 0
    
    If ws Is Nothing Then
        MsgBox "シート『5Aフロー』が見つかりません。", vbCritical
        Exit Sub
    End If
    
    ' AQ列の列番号を取得（AQ = 43列目）
    maxCol = 43 * ws.Columns(1).Width
    
    ' 既存のBA21以降、BF21以降をクリア
    ws.Range("BA21:BA1000").ClearContents
    ws.Range("BF21:BF1000").ClearContents
    
    ' コレクションを初期化
    Set rectangles = New Collection
    Set textBoxes = New Collection
    
    ' AQ列より左の範囲で四角形とテキストボックスを分類
    For Each shp In ws.Shapes
        ' AQ列より左にある図形のみを対象とする
        If shp.Left < maxCol Then
            ' グループ化されている場合の処理
            If shp.Type = msoGroup Then
                Dim grpShape As Shape
                For Each grpShape In shp.GroupItems
                    If grpShape.Type = msoAutoShape And grpShape.AutoShapeType = msoShapeRectangle Then
                        rectangles.Add grpShape
                    ElseIf grpShape.Type = msoTextBox Then
                        textBoxes.Add grpShape
                    End If
                Next grpShape
            Else
                ' 単体の図形の場合
                If shp.Type = msoAutoShape And shp.AutoShapeType = msoShapeRectangle Then
                    rectangles.Add shp
                ElseIf shp.Type = msoTextBox Then
                    textBoxes.Add shp
                End If
            End If
        End If
    Next shp
    
    ' 出力開始行
    outputRow = 21
    
    ' 四角形とテキストボックスの重なりをチェック
    For i = 1 To rectangles.Count
        Set rect = rectangles(i)
        
        ' 四角形の境界を設定
        Set rectBounds = CreateObject("Scripting.Dictionary")
        rectBounds("Left") = rect.Left
        rectBounds("Top") = rect.Top
        rectBounds("Right") = rect.Left + rect.Width
        rectBounds("Bottom") = rect.Top + rect.Height
        
        For j = 1 To textBoxes.Count
            Set txtBox = textBoxes(j)
            
            ' テキストボックスの境界を設定
            Set txtBounds = CreateObject("Scripting.Dictionary")
            txtBounds("Left") = txtBox.Left
            txtBounds("Top") = txtBox.Top
            txtBounds("Right") = txtBox.Left + txtBox.Width
            txtBounds("Bottom") = txtBox.Top + txtBox.Height
            
            ' 重なりをチェック
            If IsOverlapping(rectBounds, txtBounds) Then
                ' BA列に四角形のテキスト、BF列にテキストボックスのテキストを出力
                On Error Resume Next
                ws.Cells(outputRow, 53).Value = rect.TextFrame.Characters.Text ' BA列 = 53列目
                ws.Cells(outputRow, 58).Value = txtBox.TextFrame.Characters.Text ' BF列 = 58列目
                On Error GoTo 0
                
                outputRow = outputRow + 1
            End If
        Next j
    Next i
    
    MsgBox "処理が完了しました。" & vbCrLf & _
           "抽出されたペア数: " & (outputRow - 21) & "組", vbInformation
End Sub

' 二つの矩形が重なっているかどうかをチェックする関数
Private Function IsOverlapping(rect1 As Object, rect2 As Object) As Boolean
    ' 重なりの条件：
    ' rect1の右端がrect2の左端より右にある AND
    ' rect1の左端がrect2の右端より左にある AND  
    ' rect1の下端がrect2の上端より下にある AND
    ' rect1の上端がrect2の下端より上にある
    
    IsOverlapping = (rect1("Right") > rect2("Left")) And _
                   (rect1("Left") < rect2("Right")) And _
                   (rect1("Bottom") > rect2("Top")) And _
                   (rect1("Top") < rect2("Bottom"))
End Function