Поиск и выделение окружностей одинакового диаметра

Sub ObjectReplacer()
    Dim s As Shape, p As ShapeRange, ss As ShapeRange, ref
    ActiveDocument.BeginCommandGroup "ObjectReplacer"
    Optimization = True
    EventsEnabled = False
    ActiveDocument.SaveSettings
    ActiveDocument.PreserveSelection = False
    ref = ActiveDocument.ReferencePoint
    ActiveDocument.ReferencePoint = cdrCenter
    Set ss = ActiveSelection.Shapes.All
    Set p = ActiveLayer.PasteEx
    ppx# = p.PositionX
    ppy# = p.PositionY
    For Each s In ss    'ActiveDocument.Selection.Shapes
        'p.SizeHeight = s.SizeHeight
        'p.SizeWidth = s.SizeWidth
        p.Duplicate(s.PositionX - ppx, s.PositionY - ppy).OrderBackOf s
    Next
    p.Delete
    ss.Delete
    ActiveDocument.ReferencePoint = ref
    ActiveDocument.PreserveSelection = True
    ActiveDocument.RestoreSettings
    EventsEnabled = True
    Optimization = False
    ActiveDocument.EndCommandGroup
    ActiveWindow.Refresh
    Application.Refresh
End Sub

Sub ColorRazmerAll()
    Dim s As Shape
    Dim sSizeHeight As Double
    Dim sSizeWidth As Double
    Dim eColor As Integer
    
    For Each s In ActivePage.Shapes
        s.GetSize sSizeHeight, sSizeWidth
        sSizeHeight = Round(sSizeHeight, 3)
        'sSizeWidth = Round(sSizeWidth, 3)
        eColor = Int(sSizeHeight * 1000)
                
        s.Fill.UniformColor.RGBAssign eColor, 50, 50
Next s
End Sub

Sub ColorRazmerAll()
Dim s As Shape
Dim sSizeHeight As Double
Dim sSizeWidth As Double
Dim eColor As Integer
 
Optimization = True
EventsEnabled = False
For Each s In ActivePage.Shapes
   s.GetSize sSizeHeight, sSizeWidth
   sSizeHeight = Round(sSizeHeight, 3)
   'sSizeWidth = Round(sSizeWidth, 3)
   eColor = Int(sSizeHeight * 1000) * 5
   s.Fill.UniformColor.RGBAssign eColor, eColor / 2, eColor * 3 / 2
Next s
    EventsEnabled = True
    Optimization = False
End Sub

eColor = Int(sSizeHeight * 1000) * 5

eColor = Int(sSizeHeight * 100) * 5