最简单的方法是，让他们在没有其他形状的地方签名。让我们假设他们的范围是M11:Q31。这个sub将是该范围内左上角单元格所有形状的高度和宽度的一半（具有从N11开始的“背景”将不受影响）。

Sub kjhdrle()
  Dim x As Variant, y As String
  y = ""
  For Each x In ActiveSheet.Shapes
    If Not Intersect(x.TopLeftCell, [M11:Q31]) Is Nothing Then
      If y = "" Then
        y = x.Name
      Else
        y = y & vbLf & x.Name
      End If
    End If
  Next
  If y = "" Then Exit Sub
  ActiveSheet.Shapes.Range(Split(y, vbLf)).Select
  If InStr(y, vbLf) Then Selection.ShapeRange.Group.Select
  Selection.ShapeRange.ScaleWidth 0.5, msoFalse, msoScaleFromTopLeft
  Selection.ShapeRange.ScaleHeight 0.5, msoFalse, msoScaleFromTopLeft
End Sub

我保持的是尽可能简单。它也会分组的项目，如果超过一个，所以当调整大小，锚也将规模。（没有，每个元素将缩小自己的锚）。
另一种方法是自动重命名你不想被处理的形状...在名字前面加上类似“not_me_”的字符串。然后在运行代码时，简单地忽略以该字符串开头的形状。处理后，被sub使用的形状被重命名为"not_me_" & [shape].name，这样下次它们就会被忽略;）
如果你还有什么问题，尽管问。

我沿着这个问题是因为我有一个类似的要求。现在对我有效的是：通过比较创建前后图纸上的形状数量，可以获得最新的形状。

Sub Get_latest_Shape()

Dim lngCount As Long

    'Save the sheets current amount of shapes before adding a new one.
    lngCount = ActiveSheet.Shapes.Count

    'Add a shape.
    >> your shape-adding code here <<
    
    'Address the latest shape by calling the old shape count +1.
    MsgBox (ActiveSheet.Shapes(lngCount + 1).Name)
    
End Sub