grafik taşıma

[SMSKMHMMT]

Herkese kolay gelsin, yeni öğrenmeye çalışan biriyim bu yüzden anlayışınıza sığınarak hem grafik hem de vba ile alakalı bir sorum var yardımcı olursanız sevinirim.
Örnek dosya linkini aşağı bıraktım. Özetlemek gerekirse x sayfasında bulunan grafikleri y sayfasında bulunan açılır listeden seçip buton yardımı ile çağırmak istiyorum. Dosya içinde izah etmeye çalıştım, çağırdığım alanda aynı anda iki tane grafik olmasın yani ikinci grafik geldiğinde birinci grafik ilgili sayfadaki kendi yerine gitsin. Uzun uzadıya bir kod yazdım grafikleri getirebiliyorum, geri de gönderebiliyorum ama çok uzun bir kod olduğu için belli bir süreden sonra karıştı.
Şimdiden gelecek cevaplar için teşekkür ederim.

İndir örnek xlsx

Dosyayı indir örnek xlsx

dosya.co

 

[necati]

Private Sub CommandButton1_Click()
Dim grf As Shape, rng As Range
Dim s1 As Worksheet, s2 As Worksheet

Set s1 = ThisWorkbook.Worksheets("grafikler")
Set s2 = ThisWorkbook.Worksheets("raporlama")
Set rng = s2.Range("D4")

On Error Resume Next
For Each grf In s2.Shapes
    If Not Intersect(grf.TopLeftCell, rng) Is Nothing Then
        grf.Delete
    End If
Next grf
On Error GoTo 0

For Each grf In s1.Shapes
    If grf.Name = Range("B20").Text Then
        grf.Copy
        s2.Paste s2.Range("D4")
        Set grf = s2.Shapes(1)
        With grf
            .LockAspectRatio = msoFalse
            .Top = s2.Range("D4").Top
            .Left = s2.Range("D4").Left
            .Height = s2.Range("D4:F20").Height
            .Width = s2.Range("D4:F20").Width
            Exit For
        End With
    End If
Next grf

End Sub

 

[SMSKMHMMT]

Sayın necati verdiğiniz cevap için ve yazdığınız koddan çok fazla şey öğreneceğim için çok teşekkür ederim. İşimi gördü fakat buton görselde görüleceği üzere büyüyüp grafik alanına geliyor birşeyi yanlış yapmış olabilirim. Sizin kodunuzu kendime uyarladım aşağı onu paylaşıyorum. Tekrar teşekkür ederim.
Private Sub CommandButton2_Click()

Dim grf As Shape, rng As range
Dim s1 As Worksheet, s2 As Worksheet

Set s1 = ThisWorkbook.Worksheets("GRAFİKLER")
Set s2 = ThisWorkbook.Worksheets("PERSONEL ANALİZ SAYFASI")
Set rng = s2.range("EI5")

On Error Resume Next
For Each grf In s2.Shapes
If Not Intersect(grf.TopLeftCell, rng) Is Nothing Then
grf.Delete
End If
Next grf
On Error GoTo 0

For Each grf In s1.Shapes
If grf.Name = range("EG20").Text Then
grf.Copy
s2.Paste s2.range("EI5")
Set grf = s2.Shapes(1)
With grf
.LockAspectRatio = msoFalse
.Top = s2.range("EI5").Top
.Left = s2.range("EI5").Left
.Height = s2.range("EI5:EK25").Height
.Width = s2.range("EI5:EK25").Width
Exit For
End With
End If
Next grf

End Sub

 

[necati]

Ekli görseli göremiyorum. Tahminen yazıyorum. Kodumuzda butonun boyutunu etkileyecek bir şey bulunmuyor.
Sadece daha önce açmış olduğunuz konudaki cevabımı burada hatırlatmak isterim. Buton özelliklerini kontrol etmenizi önerebilirim.

 

[SMSKMHMMT]

Şöyle bir şey mümkün müdür? sayfada başka bir commandbutton daha bulunmakta bu butonu da shapes olarak görüp o alana mı taşıyor acaba? Özellikleri kontrol edeceğim. Yardımınız için teşekkür ederim.

 

[necati]

Mümkün ama onu önlemek için yapıştırdığımız grafiği set ederek "Set grf = s2.Shapes(1) " belirledik adeta sabitlemiş olduk. Ardından boyut belirleme işleminin ardından hemen for döngüsünden çıkıyoruz. Başka şekillere dokunmuyoruz.

 

[necati]

Sizdeki olay bende olmadığı için emin değilim ama bir de yapıştırdığımız grafiği isimlendirerek deneyelim. Belki sizde işe yarayabilir.

Option Explicit
Private Sub CommandButton1_Click()
Dim grf As Shape, rng As Range
Dim s1 As Worksheet, s2 As Worksheet

Set s1 = ThisWorkbook.Worksheets("grafikler")
Set s2 = ThisWorkbook.Worksheets("raporlama")
Set rng = s2.Range("D4")

On Error Resume Next
For Each grf In s2.Shapes
'    If Not Intersect(grf.TopLeftCell, rng) Is Nothing Then   Bu satır silindi
    If grf.Left = rng.Left And grf.Top = rng.Top Then           Bu satır konuldu 
        grf.Delete
    End If
Next grf
On Error GoTo 0

For Each grf In s1.Shapes
    If grf.Name = Range("B20").Text Then
        grf.Copy
        s2.Paste s2.Range("D4")
        Set grf = s2.Shapes(1)
        grf.Name = "SMSK"
        With s2.Shapes("SMSK")
            .LockAspectRatio = msoFalse
            .Top = s2.Range("D4").Top
            .Left = s2.Range("D4").Left
            .Height = s2.Range("D4:F20").Height
            .Width = s2.Range("D4:F20").Width
            Exit For
        End With
    End If
Next grf

End Sub