How to combine shapes using vba-excel? - vba

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