VBA代码：在工作表中自动添加矩形

Sub Add_Macro_Rectangle()
 Dim ws                    As Worksheet
 Dim sh                    As Object
 Dim sText                 As String
 Dim sDimensions           As String
 Dim rDimensions           As Range
 Dim iColor                As Integer
 Dim s As String

 On Error Resume Next

 Set ws = ActiveSheet
 sDimensions = Trim(Application.InputBox("请输入形状的大小 (行 x 列)", "形状大小", "3x3", , , , , 2))
 iColor = Trim(Application.InputBox("请输入形状的颜色: 1 =蓝色, 2 =绿色, 3 =红色", "形状的填充颜色", "2", , , , , 1))
 iColor = WorksheetFunction.Min(iColor, 3)
 iColor = WorksheetFunction.Max(iColor, 0)
 Set rDimensions = Selection.Cells(1).Resize(CDbl(Split(sDimensions, "x")(0)), CDbl(Split(sDimensions, "x")(1)))
 
 With rDimensions
   Set sh = ws.Shapes.AddShape(msoShapeRoundedRectangle, .Left, .Top, .Width, .Height)
 End With
 
 With sh
   .Name = "Run_macro"
   '水平居中
   With .TextFrame2.TextRange.Characters(1, Len(sText)).ParagraphFormat
     .FirstLineIndent = 0                 '水平居中
     .Alignment = msoAlignCenter
   End With
   '垂直居中
   With .TextFrame2
     .VerticalAnchor = msoAnchorMiddle    '垂直居中
   End With
   With .Fill
     .ForeColor.RGB = Choose(iColor, RGB(0, 176, 240), RGB(146, 208, 80), RGB(255, 0, 0))
     .Transparency = 0
     .Solid
   End With
   With .Line
     .ForeColor.RGB = sh.Fill.ForeColor.RGB
     .Transparency = sh.Fill.Transparency
   End With
   .Placement = xlMove  'xlMoveAndSize = 1, xlMove = 2, xlFreeFloating = 3
   .Select
   Application.Dialogs(xlDialogAssignToObject).Show
 
   s = Split(.OnAction, "!")(1)
   If Len(s) = 0 Then s = .OnAction
 
   sText = Trim(Application.InputBox("请输入形状中的文本", "形状文本", s, , , , , 2))
   If sText = "False" Or Len(sText) = 0 Then sText = "添加标题"
 
   With .TextFrame.Characters
     .Text = sText
     .Font.Color = vbWhite
     .Font.Bold = True
   End With
   rDimensions.Cells(1).Select
 End With
 On Error GoTo 0
 Set ws = Nothing
End Sub