How to combine shapes using vba-excel?

Question

I want to combine shapes based on range selection. Like this picture. Is it possible? Here I attached the images:

Here I attached my code

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

There is no possibility to combine shapes in Excel. But here is an example how you can draw combined borders around your selections. This might be an option for you.

So with the selection of your example we end up with this:

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

Try This and remove apostrophe ' before ' Range("D5:F9,F8:H12,H11:J15").Select 'for test

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

Click to see Picture enter image description here