Thread: Shape grouping problems

I'm drawing a set of lines to my worksheet to show a common link between them.

Ideally I'd like to group the lines together because they might need to be deleted, and doing it one line at a time is a little slow. I've worked out how to group lines, but it has an unwanted side-effect.

Sub Test()
Dim TL As Shape
Dim TLR As Range
Dim ML As Shape
Dim MLR As Range
Dim BL As Shape
Dim BLR As Range
Dim VL As Shape
Dim VLR As Range

    Set TLR = Cells(1, 1)
    Set TL = TLR.Parent.Shapes.AddLine(0, 0, 0, 0)
    Set MLR = Cells(4, 1)
    Set ML = MLR.Parent.Shapes.AddLine(0, 0, 0, 0)
    Set BLR = Cells(7, 1)
    Set BL = BLR.Parent.Shapes.AddLine(0, 0, 0, 0)
    Set VL = TLR.Parent.Shapes.AddLine(0, 0, 0, 0)
    
    With TL
        .Top = TLR.Top + (TLR.Height / 2)
        .Left = TLR.Height / 2
        .Height = 0
        .Width = TLR.Height / 2
        .Name = "TL"
    End With

    With ML
        .Top = MLR.Top + (MLR.Height / 2)
        .Left = MLR.Height / 2
        .Height = 0
        .Width = MLR.Height / 2
        .Name = "ML"
    End With

    With BL
        .Top = BLR.Top + (BLR.Height / 2)
        .Left = BLR.Height / 2
        .Height = 0
        .Width = BLR.Height / 2
        .Name = "BL"
    End With
    
    With VL
        .Top = TLR.Top + (TLR.Height / 2)
        .Left = TLR.Height
        .Height = BLR.Top + (BLR.Height / 2) - TLR.Top - (TLR.Height / 2)
        .Width = 0
        .Name = "VL"
    End With
    
    'ThisWorkbook.ActiveSheet.Shapes.Range(Array("TL", "ML", "BL", "VL")).Select
    'Selection.Group
    
    
End Sub

The above code draws 3 short lines in 3 cells, and one line connecting them all together. When they are ungrouped, I can insert and remove rows between each line and the shorter lines will retain their position relative to the cell they were drawn in which is what i want, but when they are grouped, it becomes one shape and i guess it's just stretched instead of moved.

I was wondering if there's some way to stop this from happening? I'm guessing that there isn't though.

Thanks

Hi,

this line ...

Worksheets("Sheet1").ChartObjects(1).Placement = xlFreeFloating

... will neither moves nor sized with its underlying cells ... try this.

Cheers, Marko