Makronun istedigimiz hucrede çalismasi

[byvolkan]

Selamlar
Elimde soyle bir kucuk makro kodu var fakat bu kod ile sadece b1 hucresine formes atiyor otomatik olarak halbuki ben tikladigim her hucrede ctrl+r yaptigim zaman bu formu istenilen boyutlarda aninda yapistirmasini istiyorum.
Yardimci olabilirmisiniz
tesekkurler
Sub Macro3()
'
' Touche de raccourci du clavier: Ctrl+r
'

ActiveSheet.Shapes.AddShape(msoShapeRectangle, 1003.5, 255.75, 39.75, 14.25). _
Select
End Sub

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Macro3()
    '
    ' Touche de raccourci du clavier: Ctrl+r
    '
    With ActiveCell
        ActiveSheet.Shapes.AddShape(msoShapeRectangle, .Left, .Top, .Width, .Height).Select
    End With
End Sub

 

[byvolkan]

Mukemmel sadece boyutlari hucreye gore buyumus amahizalama tam oluyor boylede sadece ayni hizalama ile kuçultmeye çalisiyorum yapabilirsem.

 

[byvolkan]

Yardimlariniz için tesekkurler boyutlandirmayida Su sekilde hallettim:



Sub Macro_Rectangle()
'
' Volki rectangle
' Touche de raccourci du clavier: Ctrl+r
'
With ActiveCell
ActiveSheet.Shapes.AddShape(msoShapeRectangle, .Left, .Top, .Width, .Height).Select
End With
Selection.ShapeRange.Fill.Visible = msoFalse
Selection.ShapeRange.ScaleWidth 0.9, msoFalse, msoScaleFromBottomRight
Selection.ShapeRange.ScaleHeight 0.8, msoFalse, msoScaleFromBottomRight
Selection.ShapeRange.ScaleWidth 0.9, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.ScaleHeight 0.8, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.IncrementLeft 0
Selection.ShapeRange.IncrementTop -0.7
End Sub

 

[Korhan Ayhan]

İlk önerimde ki aşağıdaki bold bölümlerden eksi ya da artı yaparak boyutlandırma yapabilirsiniz.

ActiveSheet.Shapes.AddShape(msoShapeRectangle, .Left, .Top, .Width, .Height).Select

Bold olan bölümlere direkt sayısal değerler yazabilirsiniz.