自动添加形状并指定宏

完美Excel · 公众号 · Excel · 2024-10-20 12:49

正文

学习Excel技术，关注微信公众号：

excelperfect

标签：VBA

下面的程序在工作表当前单元格中添加一个矩形，并指定单击该矩形时要执行的宏。可以指定矩形的大小，以及矩形中的文本。

代码如下：

Sub autoAdd_Rectangle_Macros() 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 = NothingEnd Sub

在运行程序时指定形状要执行的宏，如下图1所示。

图1

结果如下图2所示。

图2

欢迎在下面留言，完善本文内容，让更多的人学到更完美的知识。

欢迎到知识星球：完美Excel社群，进行技术交流和提问，获取更多电子资料，并通过社群加入专门的微信讨论群，更方便交流。