rakesh seebaruth

Board Regular
Joined
Oct 6, 2011
Messages
237
Hi Guys


I have the following vba codes


Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Box As Shape
Set Box = Me.Shapes("Rectangle 1")
If Selection.Left + Selection.Width _
+ Box.Width > Rows(1).Width Then
Box.Left = Selection.Left - Box.Width
Else: Box.Left = Selection.Left + Selection.Width
End If
If Selection.Top + Selection.Height _
+ Box.Height > Columns(1).Height Then
Box.Top = Selection.Top - Box.Height
Else: Box.Top = Selection.Top + Selection.Height
End If
Box.ZOrder msoBringToFront
End Sub

It works fully well with the rectangle


I have changed the rectangle to rounded rectangle


It’s not working


Your help will be highly appreciated.


Happy New Year 2019


Thanks/regards

rakesh
 

Some videos you may like

Excel Facts

Can you AutoAverage in Excel?
There is a drop-down next to the AutoSum symbol. Open the drop-down to choose AVERAGE, COUNT, MAX, or MIN

Yongle

Well-known Member
Joined
Mar 11, 2015
Messages
6,744
Office Version
  1. 365
Platform
  1. Windows
What is the new shape's name?
- select shape and look in Excel's name box

Either
- rename the shape as "Rectangle 1"
or
- amend the code to refer to the correct name
 

rakesh seebaruth

Board Regular
Joined
Oct 6, 2011
Messages
237
Thanks it works

Now how to add two shapes one Rectangle 1 and Rounded Rectangle 1 the above vba codes?

Happy new year 2019

regards

rakesh
 

Yongle

Well-known Member
Joined
Mar 11, 2015
Messages
6,744
Office Version
  1. 365
Platform
  1. Windows
In principle, simply repeat the code for each shape (see below)

But :confused::confused:
Your code is triggered EVERY time a new cell is selected - is that what you really want?
Should changes to "Rectangle 1" and "Rectangle: Rounded Corners 1" BOTH be triggered by selecting the same cell(s)?
- if not please explain what should happen

Code:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim Box As Shape
    Set Box = Me.Shapes("Rectangle 1")
        If Selection.Left + Selection.Width + Box.Width > Rows(1).Width Then
            Box.Left = Selection.Left - Box.Width
        Else: Box.Left = Selection.Left + Selection.Width
        End If

        If Selection.Top + Selection.Height + Box.Height > Columns(1).Height Then
            Box.Top = Selection.Top - Box.Height
        Else: Box.Top = Selection.Top + Selection.Height
        End If
    Box.ZOrder msoBringToFront
'Now Repeat for 2nd shape - amend properties as required
    Set Box = Me.Shapes("Rectangle: Rounded Corners 1")
        If Selection.Left + Selection.Width + Box.Width > Rows(1).Width Then
            Box.Left = Selection.Left - Box.Width
        Else: Box.Left = Selection.Left + Selection.Width
        End If

        If Selection.Top + Selection.Height + Box.Height > Columns(1).Height Then
            Box.Top = Selection.Top - Box.Height
        Else: Box.Top = Selection.Top + Selection.Height
        End If
    Box.ZOrder msoBringToFront
     
End Sub
 
Last edited:

rakesh seebaruth

Board Regular
Joined
Oct 6, 2011
Messages
237

ADVERTISEMENT

thanks but there is only one shape the rectangle 1 covers the other shape completely. The position of the second shape is not correct.
 

Yongle

Well-known Member
Joined
Mar 11, 2015
Messages
6,744
Office Version
  1. 365
Platform
  1. Windows
Do you want second shape to always be the same size and in same position as first shape?
 
Last edited:

rakesh seebaruth

Board Regular
Joined
Oct 6, 2011
Messages
237

ADVERTISEMENT

yes same size and the next the other one
 

Yongle

Well-known Member
Joined
Mar 11, 2015
Messages
6,744
Office Version
  1. 365
Platform
  1. Windows
Is this what you want?
- amend shape names if necessary

Code:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim Box As Shape, Box2 As Shape
    Set Box = Me.Shapes("[COLOR=#ff0000]Rectangle 1[/COLOR]")
    Set Box2 = Me.Shapes("[COLOR=#ff0000]Rectangle: Rounded Corners 2[/COLOR]")
[I][COLOR=#006400]'first box    [/COLOR][/I]
    With Selection
        If .Left + .Width + Box.Width > Rows(1).Width Then
            Box.Left = .Left - Box.Width
        Else: Box.Left = .Left + .Width
        End If
        If .Top + .Height + Box.Height > Columns(1).Height Then
            Box.Top = .Top - Box.Height
        Else: Box.Top = .Top + .Height
        End If
    End With
    Box.ZOrder msoBringToFront
[I][COLOR=#006400]'other box[/COLOR][/I]
    With Box
        Box2.Left = .Left + .Width
        Box2.Top = .Top
        Box2.Width = .Width
        Box2.Height = .Height
    End With
End Sub
 

Yongle

Well-known Member
Joined
Mar 11, 2015
Messages
6,744
Office Version
  1. 365
Platform
  1. Windows
leave a little space in between the shapes?

Amend this line
Code:
        Box2.Left = .Left + .Width

Try
Code:
        Box2.Left = .Left + .Width + 10
 

Watch MrExcel Video

Forum statistics

Threads
1,108,973
Messages
5,525,988
Members
409,673
Latest member
Riseee

This Week's Hot Topics

Top