---

Sub FindDuplicatesAndSortShapes()
    Dim wsSource As Worksheet
    Dim wsNew As Worksheet
    Dim shp As Shape
    Dim r As Long
    Dim lastRow As Long
    Dim rng As Range
    
    Set wsSource = ActiveSheet
    
    If wsSource.Shapes.Count = 0 Then
        MsgBox "No shapes found on this sheet!", vbExclamation, "Error"
        Exit Sub
    End If
    
    Application.ScreenUpdating = False
    
    ' Create a new report sheet
    Set wsNew = Sheets.Add
    On Error Resume Next
    wsNew.Name = "Shapes_Report_" & Format(Now, "hh_mm_ss")
    On Error GoTo 0
    
    ' Create headers
    wsNew.Range("A1").Value = "Shape Name"
    wsNew.Range("B1").Value = "Shape Type"
    wsNew.Range("A1:B1").Font.Bold = True
    wsNew.Range("A1:B1").Interior.Color = RGB(220, 220, 220)
    
    ' Collect all shapes data
    r = 2
    For Each shp In wsSource.Shapes
        wsNew.Cells(r, 1).Value = shp.Name
        wsNew.Cells(r, 2).Value = shp.Type
        r = r + 1
    Next shp
    
    lastRow = r - 1
    
    ' Sort the list alphabetically (Column A)
    With wsNew.Sort
        .SortFields.Clear
        .SortFields.Add2 Key:=wsNew.Range("A2:A" & lastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange wsNew.Range("A1:B" & lastRow)
        .Header = xlYes
        .Apply
    End With
    
    ' Highlight duplicates with light red color
    Set rng = wsNew.Range("A2:A" & lastRow)
    rng.FormatConditions.AddUniqueValues
    rng.FormatConditions(rng.FormatConditions.Count).SetFirstPriority
    rng.FormatConditions(1).DupeUnique = xlDuplicate
    
    With rng.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = RGB(255, 199, 206)
    End With
    With rng.FormatConditions(1).Font
        .Color = RGB(156, 0, 6)
    End With
    
    ' Auto-fit column widths
    wsNew.Columns("A:B").AutoFit
    Application.ScreenUpdating = True
    
    MsgBox "Done! Check the new sheet for sorted shapes and red duplicates.", vbInformation, "Success"
End Sub