如何使用vba-excel合並形狀？

Question

我想根據范圍選擇來組合形狀。 喜歡這張照片。 可能嗎？ 在這里，我附上了圖片：

在這里我附上了我的代碼

Sub cohabitationButton_Click()
    '''''split range
    Dim s() As String
    Dim txt As String
    Dim i As Long

    s = Split(Selection.Address(False, False), ",")    

    For i = LBound(s) To UBound(s)
        Dim r As range: Set r = range(s(i))
        With r
            l = .Left - 5
            t = .Top - 5
            w = .Width + 10
            h = .Height + 10
        End With
        ShapeName = "ex"

        With ActiveSheet.Shapes.AddShape(msoShapeFlowchartTerminator, l, t, w, h)
            .Fill.Visible = msoFalse
            .Line.Weight = 1
            .Line.DashStyle = msoLineDash
            .Line.ForeColor.RGB = BASICCOLOR
            .Name = ShapeName
        End With  
    Next i
End Sub

Answer 1

無法在Excel中組合形狀。 但是這是一個示例，您可以如何在選擇周圍繪制組合邊框。 這可能是您的選擇。

因此，通過選擇您的示例，我們得出以下結論：

Sub DrawCombinedBordersOnly()
    '''''split range
    Dim s() As String
    Dim txt As String
    Dim i As Long

    Dim rngOverlappings As Range

    'Draw borders around all selected ranges
    Selection.BorderAround LineStyle:=xlDot, Weight:=xlThin

    s = Split(Selection.Address(False, False), ",")

    For i = LBound(s) To UBound(s)
        Dim r As Range: Set r = Range(s(i))
        Dim j As Long
        For j = LBound(s) To UBound(s)
            'find overlapping areas
            If i <> j And Not Application.Intersect(r, Range(s(j))) Is Nothing Then
                If rngOverlappings Is Nothing Then
                    Set rngOverlappings = Application.Intersect(r, Range(s(j)))
                Else
                    Set rngOverlappings = Union(rngOverlappings, Application.Intersect(r, Range(s(j))))
                End If
            End If
        Next j
    Next i

    ' remove borders from overlappings
    If Not rngOverlappings Is Nothing Then
        rngOverlappings.Borders.LineStyle = xlNone
    End If
End Sub

Answer 2

嘗試執行此操作並刪除' Range（“ D5：F9，F8：H12，H11：J15”）之前的撇號。選擇'進行測試

Sub cohabitationButton_Click()
    '''''split range
    Dim WB As Workbook
    Dim WS As Worksheet
     Dim s() As String
    Dim txt As String
    Dim i As Long
    Dim Shp As Shape
    Dim L  As Single, T  As Single, Lft As Single, Tp As Single
    Set WB = ThisWorkbook 'Set WB = Workbooks("WorkbookName")
    Set WS = WB.ActiveSheet 'Set WS = WB.WorkSheets("WorkSheetName")

 With WS
    For Each Shp In .Shapes
    If Shp.Type = 5 Then Shp.Delete
    Next

   ' Range("D5:F9,F8:H12,H11:J15").Select 'for test***
MyRange = Selection.Address
    s = Split(Selection.Address(False, False), ",")
    Dim Names(1 To 100) As Variant

    For i = LBound(s) To UBound(s)
        Dim r As Range: Set r = Range(s(i))
        With r
            L = .Left - 5
            T = .Top - 5
            w = .Width + 10
            h = .Height + 10
            If i = LBound(s) Then
            Lft = L
            Tp = T
            End If
            If Lft > L Then Lft = L
            If Tp > T Then Tp = T
        End With
        ShapeName = "ex"

        With .Shapes.AddShape(msoShapeFlowchartTerminator, L, T, w, h)
            .Fill.Visible = msoFalse
            .Line.Weight = 1
            .Line.DashStyle = msoLineDash
            .Line.ForeColor.RGB = BASICCOLOR
            .Name = Replace(.Name, "Flowchart: Terminator", ShapeName)
            Names(i + 1) = .Name

        End With
    Next i
    .Activate
    .Shapes.Range(Names).Select

        Selection.Cut
         Call MangeCombinePPTFromExcel(WS, Lft, Tp)
.Range(MyRange).Select

End With 'WS

End Sub

Public Sub MangeCombinePPTFromExcel(WS As Worksheet, Lft As Single, Tp As Single)

Dim PPT As Object
Dim Pres As Object
Dim Sld As Object
Dim Shp As Shape, Rctangl As Shape, Rctangll As Shape, MergeShape As Shape

Set PPT = CreateObject("Powerpoint.Application")
Set Pres = PPT.Presentations.Add
Set Sld = Pres.Slides.Add(1, 12)
 PPT.Activate

 ShapeName = "ex"

    With Sld
        .Shapes.Paste.Select
        On Error Resume Next
         PPT.CommandBars.ExecuteMso ("ShapesUnion")
        On Error GoTo 0
         .Shapes(.Shapes.Count).Cut


    End With
            With WS 'back to Excel
                .Paste
                With .Shapes(.Shapes.Count)
                .Name = ShapeName
                    .Left = Lft
                    .Top = Tp
                End With
            End With
  PPT.Quit
End Sub

單擊以查看圖片在此處輸入圖片說明