Bir sayfadan başka sayfaya bir bölümün resmini almak

[Filose]

Herkese merhaba,
Excelde bir sayfadan istediğimiz alanın resmini diğer sayfaya aktarmak istiyorum. Bunu aynı sayfadan aynı sayfaya aşağıdaki kodla yapabiliyorum. Ancak diğer sayfadan resim almayı beceremedim.

Sub Resim01()
Dim Pic As Picture
Range("BP22:CA28").CopyPicture
Set Pic = ActiveSheet.Pictures.Paste
Pic.Top = [R13].Top 'Yukarıdan pozisyon
Pic.Left = [R13].Left 'Soldan pozisyon
End Sub

Yardımcı olabilecek arkadaşlara şimdiden teşekkür ediyorum.

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit
Dim Kontrol As Boolean

Sub Hucreleri_Resim_Yapistir()
    Dim Resim As Picture
    If Kontrol = False Then
        Worksheets("Veri").Range("D7:O13").CopyPicture xlScreen, xlBitmap
        Worksheets("Bigi").Paste Destination:=Worksheets("Bigi").Range("H8")
        Kontrol = True
    Else
        For Each Resim In Worksheets("Bigi").Pictures
            If Not Intersect(Resim.TopLeftCell, Worksheets("Bigi").Range("H8:S14")) Is Nothing Then
                Resim.Delete
            End If
        Next
        Kontrol = False
    End If
End Sub

 

[YUSUF44]

Bunun için Excel'in "fotoğraf" özelliğini de kullanabilirsiniz.

 

[Filose]

Korhan Bey, teşekkür ediyorum ellerinize sağlık. Söylemeyi unuttuğum bir şey vardı.

Resmin geldiği sayfada yani H8 de makro butonuna tıkladığımızda resim geliyor. Bir daha tıkladığımızda silinmesini sağlayabilir miyiz acaba.
Yani bir tıkla gelecek ikinci tıkla silecek.

Sağlık ve huzur diliyorum.

 

[Korhan Ayhan]

Kodu revize ettim. Deneyiniz.

 

[Filose]

Korhan Bey,

Ellerinize sağlık çok teşekkür ediyorum.
Sadece VERİ Sayfasından belirlenen alanın resmini BİGİ sayfasına yapıştırdığında
orjinalinden bir hayli büyük yapıştırıyor.

Her iki sayfanın sayfa boyutları ve kenar boşlukları hatta ölçekleri de aynı olmasına rağmen
yapıştırılan yerde büyük oluyor. Anlayamadım.

Saygı ve hürmetle kalın.

 

[Korhan Ayhan]

Ben denediğimde boyut sorunu olmuyor. Bir de aşağıdaki kodu deneyin.

Option Explicit
Dim Kontrol As Boolean

Sub Hucreleri_Resim_Yapistir()
    Dim Resim As Picture
    If Kontrol = False Then
        Worksheets("Veri").Range("D7:O13").CopyPicture xlScreen, xlPicture
        Worksheets("Bigi").Paste Destination:=Worksheets("Bigi").Range("H8")
        Kontrol = True
    Else
        For Each Resim In Worksheets("Bigi").Pictures
            If Not Intersect(Resim.TopLeftCell, Worksheets("Bigi").Range("H8:S14")) Is Nothing Then
                Resim.Delete
            End If
        Next
        Kontrol = False
    End If
End Sub

 

[Filose]

Bende her iki sayfada sütün genişlikleri 1 olarak ayarlandı sorun ondan sanırım.

Her şey için teşekkür ediyorum.

 

[Korhan Ayhan]

Dediğiniz şekilde de denedim. Bende boyut değişikliği olmuyor. Sizin kullandığınız versiyonla ilgili bir durum olabilir.

 

[Filose]

Evet dediğiniz gibi size gönderdiğim dosya üzerinde denediğimde hiç sorun yok.
Farklı bir dosyada denediğimde sorun oluyor. Muhtemelen gözümden kaçan bir şey var bulacağım.

Tekrar teşekkür ediyorum.

Saygılar