Resize the shape with ScaleWidth 1.5

[haseft]

Hi!

The following works great.
But I want to resize the shape with ScaleWidth 1.5 befor copy it to new cell.
I get error.
Please help.

Function ShapeAtActiveCell() As String
  Dim Sh As Shape
  For Each Sh In ActiveSheet.Shapes
    If Sh.TopLeftCell.Address = ActiveCell.Address Then
      ShapeAtActiveCell = Sh.Name
      Exit Function
    End If
  Next
End Function

'--------------
With Worksheets("Blad2")
  .ShapeRange.ScaleWidth 1.5 ' I want to resize/ScaleWidth 1.5 befor copy
  .Shapes(ShapeAtActiveCell).Copy
End With
With Worksheets("Blad2")
   .Paste Destination:=.Cells(j, "C")
End With

 

[John_w]

Try this. I've changed the ShapeAtActiveCell function to return a Shape object instead of a shape name.

Public Sub Test()
    
    Dim shp As Shape, j As Long
    
    j = 10
    With Worksheets("Blad2")
        Set shp = ShapeAtActiveCell
        If Not shp Is Nothing Then
            Set shp = shp.Duplicate
            shp.Top = .Cells(j, "C").Top
            shp.Left = .Cells(j, "C").Left
            shp.ScaleWidth 1.5, msoFalse
        End If
    End With

End Sub

Private Function ShapeAtActiveCell() As Shape
    
    Dim shp As Shape
    
    For Each shp In ActiveSheet.Shapes
        If Not Intersect(ActiveCell, Range(shp.TopLeftCell, shp.BottomRightCell)) Is Nothing Then
            Set ShapeAtActiveCell = shp
            Exit Function
        End If
    Next
    
End Function

 

[haseft]

Thanks a lot John.
It works great.