Sayfada Hücre aralığını şekle dolgu olarak getirmek

[pNouma]

Kıymetli Hocalarım merhaba

Sayfa1 içinde "N2:Y19" hücre aralığını kopyalayıp;

sayfa2' de dikdörtgen şeklindeki şekil (Shape1) içine resim olarak kopyalamak istiyordum;

kısacası bu hücre aralığı shape1 şeklinin dolgusu olacak

yardımlarını için şimdiden teşekkürler,

Sub Tester()
    Sayfa1.Range("N2:Y19").Copy
    Sayfa2.Activate
   
    Sayfa2.Shapes("Shape1").Paste
    Application.CutCopyMode = False
    
End Sub

iyi çalışmalar.

 

[volki_112]

Kıymetli Hocalarım merhaba

Sayfa1 içinde "N2:Y19" hücre aralığını kopyalayıp;

sayfa2' de dikdörtgen şeklindeki şekil (Shape1) içine resim olarak kopyalamak istiyordum;

kısacası bu hücre aralığı shape1 şeklinin dolgusu olacak

yardımlarını için şimdiden teşekkürler,

Sub Tester()
    Sayfa1.Range("N2:Y19").Copy
    Sayfa2.Activate
   
    Sayfa2.Shapes("Shape1").Paste
    Application.CutCopyMode = False
    
End Sub

iyi çalışmalar.

Deneyiniz

Sub HucreAraliginiSekleResimOlarakYapistir()

    Dim kaynakSayfa As Worksheet
    Dim hedefSayfa As Worksheet
    Dim hedefSekil As Shape
    Dim geciciGrafik As ChartObject

    ' Kaynak ve hedef sayfaları tanımla
    Set kaynakSayfa = ThisWorkbook.Sheets("Sayfa1")
    Set hedefSayfa = ThisWorkbook.Sheets("Sayfa2")

    ' Hedef şekli tanımla
    On Error Resume Next ' Şekil bulunamazsa hatayı atla
    Set hedefSekil = hedefSayfa.Shapes("Shape1")
    On Error GoTo 0 ' Hata işlemeyi tekrar etkinleştir

    ' Eğer hedef şekil bulunamazsa çık
    If hedefSekil Is Nothing Then
        MsgBox "Sayfa2 üzerinde 'Shape1' adlı bir şekil bulunamadı.", vbExclamation
        Exit Sub
    End If

    ' Kopyalanacak hücre aralığını seç
    kaynakSayfa.Range("N2:Y19").CopyPicture Appearance:=xlScreen, Format:=xlPicture

    ' Geçici bir grafik nesnesi oluştur (yapıştırma için gereklidir)
    Set geciciGrafik = hedefSayfa.ChartObjects.Add(Left:=10, Top:=10, Width:=100, Height:=100)
    geciciGrafik.Chart.Paste

    ' Yapıştırılan resmi şeklin boyutlarına göre ayarla ve şeklin ortasına taşı
    With geciciGrafik.ShapeRange
        .LockAspectRatio = msoFalse ' En boy oranını kilitlemeyi kaldır
        .Width = hedefSekil.Width
        .Height = hedefSekil.Height
        .Left = hedefSekil.Left
        .Top = hedefSekil.Top
    End With

    ' Şeklin dolgusunu resimle değiştir
    hedefSekil.Fill.UserPicture geciciGrafik.Chart.Shapes(1).Name

    ' Geçici grafiği sil
    geciciGrafik.Delete

    MsgBox "Hücre aralığı Shape1 şeklinin dolgusu olarak başarıyla kopyalandı.", vbInformation

End Sub

 

[Muzaffer Ali]

Merhaba.
Alternatif

Sub Test()
    Dim rng As Range
    Dim Obj As ChartObject
    Dim TempPng As String
    Dim shp As Shape
   
    Set rng = Worksheets("Sayfa1").Range("N2:Y19")
    TempPng = ThisWorkbook.Path & "\temp.png"
    rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture
    Set Obj = Worksheets("Sayfa2").ChartObjects.Add(Left:=100, Top:=100, Width:=rng.Width, Height:=rng.Height)
    Obj.Activate
    Obj.Chart.Paste
    Obj.Chart.Export fileName:=TempPng, FilterName:="PNG"
    Obj.Delete
    Set shp = Worksheets("Sayfa2").Shapes("Shape1")
    shp.Fill.UserPicture TempPng
    Kill TempPng
End Sub

 

[pNouma]

Merhaba.
Alternatif

Sub Test()
    Dim rng As Range
    Dim Obj As ChartObject
    Dim TempPng As String
    Dim shp As Shape
  
    Set rng = Worksheets("Sayfa1").Range("N2:Y19")
    TempPng = ThisWorkbook.Path & "\temp.png"
    rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture
    Set Obj = Worksheets("Sayfa2").ChartObjects.Add(Left:=100, Top:=100, Width:=rng.Width, Height:=rng.Height)
    Obj.Activate
    Obj.Chart.Paste
    Obj.Chart.Export fileName:=TempPng, FilterName:="PNG"
    Obj.Delete
    Set shp = Worksheets("Sayfa2").Shapes("Shape1")
    shp.Fill.UserPicture TempPng
    Kill TempPng
End Sub

teşekkürler Hocam

 

[pNouma]

Deneyiniz

Sub HucreAraliginiSekleResimOlarakYapistir()

    Dim kaynakSayfa As Worksheet
    Dim hedefSayfa As Worksheet
    Dim hedefSekil As Shape
    Dim geciciGrafik As ChartObject

    ' Kaynak ve hedef sayfaları tanımla
    Set kaynakSayfa = ThisWorkbook.Sheets("Sayfa1")
    Set hedefSayfa = ThisWorkbook.Sheets("Sayfa2")

    ' Hedef şekli tanımla
    On Error Resume Next ' Şekil bulunamazsa hatayı atla
    Set hedefSekil = hedefSayfa.Shapes("Shape1")
    On Error GoTo 0 ' Hata işlemeyi tekrar etkinleştir

    ' Eğer hedef şekil bulunamazsa çık
    If hedefSekil Is Nothing Then
        MsgBox "Sayfa2 üzerinde 'Shape1' adlı bir şekil bulunamadı.", vbExclamation
        Exit Sub
    End If

    ' Kopyalanacak hücre aralığını seç
    kaynakSayfa.Range("N2:Y19").CopyPicture Appearance:=xlScreen, Format:=xlPicture

    ' Geçici bir grafik nesnesi oluştur (yapıştırma için gereklidir)
    Set geciciGrafik = hedefSayfa.ChartObjects.Add(Left:=10, Top:=10, Width:=100, Height:=100)
    geciciGrafik.Chart.Paste

    ' Yapıştırılan resmi şeklin boyutlarına göre ayarla ve şeklin ortasına taşı
    With geciciGrafik.ShapeRange
        .LockAspectRatio = msoFalse ' En boy oranını kilitlemeyi kaldır
        .Width = hedefSekil.Width
        .Height = hedefSekil.Height
        .Left = hedefSekil.Left
        .Top = hedefSekil.Top
    End With

    ' Şeklin dolgusunu resimle değiştir
    hedefSekil.Fill.UserPicture geciciGrafik.Chart.Shapes(1).Name

    ' Geçici grafiği sil
    geciciGrafik.Delete

    MsgBox "Hücre aralığı Shape1 şeklinin dolgusu olarak başarıyla kopyalandı.", vbInformation

End Sub

Çok teşekkür ederim Hocam
iyi akşamlar.