Macro'yla Excel'e İçinde Yazı Bulunan Şekil Eklenmesi

 Public Sub SekilEkle()
 

  '100 nokta sağa, 50 nokta aşağıya 120 nokta genişliğinde 160 nokta yüksekliğinde dikdörtgen oluşturulması
   ActiveSheet.Shapes.AddShape msoShapeRectangle, 100, 50, 120, 160
 
  'Dikdörtgenin içinin yeşil renkli yapılması

  ActiveSheet.Shapes(1).Fill.ForeColor.RGB = vbGreen

  'Yazı renginin siyah yapılması
  ActiveSheet.Shapes(1).TextFrame.Characters.Font.ColorIndex = 1
 

  'Son satir numarasının bulunması
  SonSatir = Cells(Rows.Count, "A").End(xlUp).Row
 

  Satir = ""    'Dikdörtgenin içinin satır yazısı değişkeninin temizlenmesi 

  'Birinci satırdan son satıra kadar
  For r = 1 To SonSatir
  

   'Dikdörtgenin içindeki satır yazısının oluşturulması
   Satir = Satir & ActiveSheet.Cells(r, 1) & Chr(13)

   'Satır yazısının dikdörtgen içindeki metin kısmına atanması 
   ActiveSheet.Shapes(1).TextFrame.Characters.Text = Satir
  
   If r = 1 Then    'Birinci satırsa 
     Baslik = ActiveSheet.Cells(r, 1)    'Başlık yazısının uzunluk hesabı için elde edilmesi

     'Birinci karakterden Başlık yazısının uzunluğu kadar karakterin Bold yapılması

     ActiveSheet.Shapes(1).TextFrame.Characters(1, Len(Baslik)).Font.Bold = True
   Else
    'Değilse Başlık yazısının uzunluğundan geri kalanının Bold olmamasının sağlanması

     ActiveSheet.Shapes(1).TextFrame.Characters(Len(Baslik), Len(Satir) - Len(Baslik)).Font.Bold = False
   End If

 Next r   'Döngünün ilk satırına dönülmesi

End Sub

'------------------------------------------------------------------------------------------------------------------------

Prosedür

Prosedür Çalıştırılmadan Önce

Prosedürler Menüsünün Alt+F8 Tuşuyla Çağrılması

Prosedür Çalıştıktan Sonra