Grouping nearby shapes

Question

I have two shapes that are near each other, one of them is selected. I need to be able to group it together with the selected shape.

Thanks for your help!

Here's the code I came with but it doesn't seem to match the nearby shape. In particular its not finding a 20ptx20pt rectangle offset about half its with to the left and half its height to the top:

Option Explicit
Sub Test()
Dim oSl As slide
Dim oSh As Shape
Dim oSh2 As Shape
    
Dim MainHeight As Long
Dim MainWidth As Long

MainHeight = 48.76
MainWidth = 88.45
    
    
Set oSl = Application.ActiveWindow.View.slide
Set oSh = ActiveWindow.Selection.ShapeRange(1)

        For Each oSh2 In oSl.Shapes
            If IsWithinRangey(oSh, oSh2, 0.4) Then
                oSh2.Select (False)
            End If
        Next
''        ActiveWindow.Selection.ShapeRange.Group
    
End Sub

Function IsWithinRangey(oSh As Shape, oSh2 As Shape, _
    AreaTolerance As Single) As Boolean
' Is the shape within the coordinates supplied?

    Dim WidthMin As Single
    Dim WidthMax As Single
    Dim HeightMin As Single
    Dim HeightMax As Single

    With oSh
    
        HeightMin = oSh.Height * (1 - AreaTolerance)
        HeightMax = oSh.Height * (1 + AreaTolerance)
        WidthMin = oSh.Width * (1 - AreaTolerance)
        WidthMax = oSh.Width * (1 + AreaTolerance)
    
        Debug.Print "==========================="
        Debug.Print "Shp: " & .Width & " x " & .Height
        Debug.Print "Min: " & WidthMin & " x " & HeightMin
        Debug.Print "Max: " & WidthMax & " x " & HeightMax
    End With

       
   With oSh2
   
        If oSh.Id <> oSh2.Id Then
            ShapeLeft = oSh.Left - (19.85) / 1
            ShapeTop = oSh.Top - (19.85) / 1
            
            Debug.Print ShapeLeft
            Debug.Print ShapeTop
            
            
            If .Left >= ShapeLeft And .Left < ShapeLeft + WidthMax Then
                If .Top >= ShapeTop And .Top < ShapeTop + HeightMax Then
                    If .Width >= WidthMin And .Width <= WidthMax Then
                        If .Height > HeightMin And .Height < HeightMax Then
                            IsWithinRangey = True
                    End If
                    End If
                End If
            End If
        End If
    End With

End Function

Answer 1

Thanks to @JohnKorchok! Final code follows

Option Explicit

Dim WidthMax As Single
Dim HeightMax As Single
Dim ShapeLeft As Single
Dim ShapeTop As Single
Dim AreaTolerance As Single
Dim StepNumberWidth As Single
Dim StepNumberHeight As Single
Dim oNewShape As Shape


Sub GroupCloseShapes()
    Dim oSl As Slide
    Dim oSh As Shape
    Dim oSh2 As Shape
    Dim MainHeight As Long
    Dim MainWidth As Long

    MainHeight = 48.76
    MainWidth = 88.45
    StepNumberWidth = 19.85
    StepNumberHeight = 19.85
    
    Set oSl = Application.ActiveWindow.View.Slide
    Set oSh = ActiveWindow.Selection.ShapeRange(1)

    With oSh
        HeightMax = oSh.Height * (1 + AreaTolerance)
        WidthMax = oSh.Width * (1 + AreaTolerance)
        ShapeLeft = oSh.Left - StepNumberWidth / 1
        ShapeTop = oSh.Top - StepNumberHeight / 1
        
    End With
    
    For Each oSh2 In oSl.Shapes
        If oSh.Id <> oSh2.Id Then
            If IsWithinRangey(oSh, oSh2, 0.4) Then
                oSh2.Select (False)
            End If
        End If
    Next
'' ActiveWindow.Selection.ShapeRange.Group
End Sub

Function IsWithinRangey(oSh As Shape, oSh2 As Shape, AreaTolerance As Single) As Boolean ' Is the shape within the coordinates supplied?
    With oSh2
        If .Left >= ShapeLeft And .Left <= ShapeLeft + WidthMax Then
            If .Top >= ShapeTop And .Top <= ShapeTop + HeightMax Then
                If .Width <= WidthMax Then
                    If .Height <= HeightMax Then
                        IsWithinRangey = True
                    End If
                End If
            End If
        End If
    End With
End Function