Question

以下代码成功插入了带箭头的行，并在一组合并单元格中添加了左侧和右侧单元格边缘边框，这些单元格的数量由变量p_length确定：

android.enableAapt2=false

我尝试了以下代码将其删除。它可以成功删除单元格边缘边界并取消合并单元格，但箭头线不会被删除。我需要更改什么？

'Add length dimension arrows/lines  
Set Top_Line = Range(Cells(4, 20), Cells(4, 20 + p_length - 1))
Worksheets("Drawing").Shapes.AddConnector(msoConnectorStraight, 
Top_Line.Left, Top_Line.Top + (Top_Line.Height / 2), Top_Line.Left + 
Top_Line.width, _
Top_Line.Top + (Top_Line.Height / 2)).Select

With Selection
    With .ShapeRange.Line
         .EndArrowheadStyle = msoArrowheadOpen
         .BeginArrowheadStyle = msoArrowheadOpen
         .ForeColor.RGB = RGB(0, 0, 0)
    End With
End With

Worksheets("Drawing").Range("T4").Borders(xlEdgeLeft).LineStyle = 
xlContinuous
Worksheets("Drawing").Range(Cells(4, 20), Cells(4, 20 + p_length - 
1)).Borders(xlEdgeRight).LineStyle = xlContinuous
Worksheets("Drawing").Range(Cells(4, 20), Cells(4, 20 + p_length - 1)).Merge

好。这是所有修改后的子代码，并建议添加以下内容：

'Remove length dimension arrows/lines
Worksheets("Drawing").Range(Cells(4, 20), Cells(4, 20 + p_length - 1)).Clear
Worksheets("Drawing").Range(Cells(4, 20), Cells(4, 20 + p_length - 1)).UnMerge

我试图按照建议的名称命名（Dim_Line），但在该行出现“类型不匹配”错误-Set MyShape = Selection。如果选区确实是一个形状，那为什么会出错？

Answer 1

如果将Name分配给Shape，则可以通过Name删除它。所以之后：

Worksheets("Drawing").Shapes.AddConnector(msoConnectorStraight, 
     Top_Line.Left, Top_Line.Top + (Top_Line.Height / 2), Top_Line.Left + 
     Top_Line.width, _
     Top_Line.Top + (Top_Line.Height / 2)).Select

包括以下内容：

Dim MyShape as Shape
Set MyShape = Selection
MyShape.Name = "whatever"

然后，如果以后要删除图形，请使用：

ActiveSheet.Shapes("whatever").Delete

Answer 2

找到2004年的这篇文章https://www.ozgrid.com/forum/forum/help-forums/excel-general/15946-deleting-a-line后终于解决了！

放弃.Select，而是将线条设置为形状（shpLength和shpWidth），然后指定这些名称（lShapeName和wShapeName）。

Sub DrawPontoon_Click()
Dim ws As Worksheet
Dim p_length, p_width As Integer
Dim Top_Line As Range
Dim Side_Line As Range
Dim shpLength, shpWidth As Shape
Dim lShapeName, wShapeName As String

Set ws = Worksheets("Drawing")

With ws

'Get Pontoon Length and Width sizes
p_length = Range("pontoon_Length").Value ' pontoon_Length is the name allocated to Pontoon Length Cell in Drawing Worksheet
p_width = Range("pontoon_Width").Value   ' pontoon_Width is the name allocated to Pontoon Width in Drawing Worksheet
'MsgBox "Length is " & p_length & ", Width is " & p_width

'Draw pontoon by copying the image located at Named Cell P31 (Double_Float_Picture) and paste it into each cell in defined range
.Range("Double_Float_Picture").Copy .Range(Cells(6, 20), Cells(6 + p_width - 1, 20 + p_length - 1))

'Add length dimension line
Set Top_Line = Range(Cells(4, 20), Cells(4, 20 + p_length - 1))
Set shpLength = .Shapes.AddConnector(msoConnectorStraight, Top_Line.Left + 2, Top_Line.Top + (Top_Line.Height / 2), Top_Line.Left + Top_Line.Width - 2, _
Top_Line.Top + (Top_Line.Height / 2)) 'Modified here: Removed .Select

' Make arrows and color black
        On Error Resume Next
         With shpLength
            .Name = "LengthLine" 'Assign name to enable later deletion
            .Line.EndArrowheadStyle = msoArrowheadOpen
            .Line.BeginArrowheadStyle = msoArrowheadOpen
            .Line.ForeColor.RGB = RGB(0, 0, 0)
        End With
    Application.ScreenUpdating = True

'Add length line cell borders
.Range(Cells(4, 20), Cells(4, 20)).Borders(xlEdgeLeft).LineStyle = xlContinuous
.Range(Cells(4, 20), Cells(4, 20 + p_length - 1)).Borders(xlEdgeRight).LineStyle = xlContinuous
.Range(Cells(4, 20), Cells(4, 20 + p_length - 1)).Merge

'Add length dimension
.Range(Cells(3, 20), Cells(3, 20 + p_length - 1)).Merge
.Range(Cells(3, 20), Cells(3, 20)).HorizontalAlignment = xlCenter
.Range(Cells(3, 20), Cells(3, 20)).Formula = "=RoundUp((D38), 1) & "" m"""

'Add width dimension line
Set Side_Line = Range(Cells(6, 20 + p_length + 1), Cells(6 + p_width - 1, 20 + p_length + 1))
Set shpWidth = .Shapes.AddConnector(msoConnectorStraight, Side_Line.Left + (Side_Line.Width / 2), Side_Line.Top + 2, Side_Line.Left + (Side_Line.Width / 2), _
Side_Line.Top + Side_Line.Height - 2) ' Modified here: Removed .Select

' Make arrows and color black
On Error Resume Next
         With shpWidth
            .Name = "WidthLine" ' Assign name to enable later deletion
            .Line.EndArrowheadStyle = msoArrowheadOpen
            .Line.BeginArrowheadStyle = msoArrowheadOpen
            .Line.ForeColor.RGB = RGB(0, 0, 0)
        End With
    Application.ScreenUpdating = True

'Add width line cell borders
Dim widthLineAddr As String
widthLineAddr = Cells(6, 20 + p_length + 1).Address & ":" & Cells(6 + p_width - 1, 20 + p_length + 1).Address
.Range(widthLineAddr).Borders(xlEdgeTop).LineStyle = xlContinuous
.Range(widthLineAddr).Borders(xlBottom).LineStyle = xlContinuous
.Range(widthLineAddr).Merge


'Add width dimension
Dim widthDimensionAddr As String
widthDimensionAddr = Cells(6, 20 + p_length + 2).Address & ":" & Cells(6 + p_width - 1, 20 + p_length + 2).Address
.Range(widthDimensionAddr).Merge
.Range(widthDimensionAddr).VerticalAlignment = xlCenter
.Range(widthDimensionAddr).Orientation = xlDownward
.Range(widthDimensionAddr).Formula = "=RoundUp((D39), 1) & "" m"""

End With

MsgBox "Drawing complete"
End Sub

要删除随后使用的行：

    'Remove length dimension line
    lShapeName = "LengthLine"
    On Error Resume Next
    Shapes(lShapeName).Delete

    'Remove width dimension line
     wShapeName = "WidthLine"
    On Error Resume Next
    Shapes(wShapeName).Delete

尝试删除以前插入的形状对象

2 个答案: