İki Resim Getirme

zerali

Altın Üye
Katılım
30 Ocak 2013
Mesajlar
368
Excel Vers. ve Dili
2010 türkçe
Altın Üyelik Bitiş Tarihi
27-02-2029
Arkadaşlar yapacağım Babalar günü etkinliği için babalara sürpriz olsun diye her öğrenciye bir şiir yazdırıp babasıyla çekilmiş 2 fotoğrafını koyacağım bir belge hazırlayacağım. Bu belgede ismi seçtiğimde ismi resmi getir düğmesine bastığımda resimlerini getirmesini istiyorum. Bu çalışmayı yapmakta yardımcı olabilirseniz çok memnun olurum .şimdiden çok teşekkürler

https://www.dosya.tc/server34/2q7xkp/mel_babammm.xlsm.html
 

EmrExcel16

Destek Ekibi
Destek Ekibi
Katılım
1 Kasım 2012
Mesajlar
1,524
Excel Vers. ve Dili
Office 365 Türkçe
Merhaba , sayfanın kod bölümüne yapıştırıp deneyiniz..

Düğme kullanmanıza gerek kalmasın diye isim değiştiğinde resim otomatik geliyor.

Kod:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("O3")) Is Nothing Then Exit Sub
    Dim Resim, ResimAdi, Adress, ResAdres
    On Error Resume Next
    For Each Resim In ActiveSheet.Shapes
        Adress = Resim.TopLeftCell.Address
        If [C10].Address = Adress Or [H10].Address = Adress Then
            If Resim.Type <> 8 Then
                Resim.ShapeRange.LockAspectRatio = msoFalse
                Resim.Delete
            End If
        End If
    Next
    For Each Resim In Sheets("resim").Shapes
        Adress = Resim.TopLeftCell.Column
        ResimAdi = Sheets("resim").Cells(Resim.TopLeftCell.Row, 7).Value
        If ResimAdi = [O3] Then
            Resim.Copy
            If Adress = 1 Then
                ActiveSheet.Paste Destination:=Cells(10, 3)
                ResAdres = Cells(10, 3).Column
            Else
                ActiveSheet.Paste Destination:=Cells(10, 8)
                ResAdres = Cells(10, 8).Column
            End If
            With Cells(10, ResAdres)
                Selection.ShapeRange.LockAspectRatio = msoFalse
                Selection.Height = .MergeArea.Height + 110
                Selection.Width = .MergeArea.Width + 100
                Selection.Top = .Top + 2
                Selection.Left = .Left + 2
                Selection.Placement = xlMoveAndSize
            End With
        End If
        [O3].Select
    Next
End Sub
 

zerali

Altın Üye
Katılım
30 Ocak 2013
Mesajlar
368
Excel Vers. ve Dili
2010 türkçe
Altın Üyelik Bitiş Tarihi
27-02-2029
EmrExcel16 hocam kodu yapıştırdım ismi değiştirdim ama resim gelmedi yanlış bir şey mi yaptım
 

EmrExcel16

Destek Ekibi
Destek Ekibi
Katılım
1 Kasım 2012
Mesajlar
1,524
Excel Vers. ve Dili
Office 365 Türkçe
"Sayfanın" kod bölümüne yapıştırmanız gerekiyor , belki burada karıştırmış olabilirsiniz .
 

zerali

Altın Üye
Katılım
30 Ocak 2013
Mesajlar
368
Excel Vers. ve Dili
2010 türkçe
Altın Üyelik Bitiş Tarihi
27-02-2029
Evet karıştırmışım şimdi yapıştırdım oldu. Çok teşekkür ederim Emeğinize sağlık. 41 öğrencim var Bunun için bir değişiklik yapmama gerek var mı acaba?
 

EmrExcel16

Destek Ekibi
Destek Ekibi
Katılım
1 Kasım 2012
Mesajlar
1,524
Excel Vers. ve Dili
Office 365 Türkçe
Rica ederim , öğrenci sayısı önemli değil bu şekilde kullanabilirsiniz.
 

zerali

Altın Üye
Katılım
30 Ocak 2013
Mesajlar
368
Excel Vers. ve Dili
2010 türkçe
Altın Üyelik Bitiş Tarihi
27-02-2029
Çok teşekkürler
 

zerali

Altın Üye
Katılım
30 Ocak 2013
Mesajlar
368
Excel Vers. ve Dili
2010 türkçe
Altın Üyelik Bitiş Tarihi
27-02-2029
EmrExcel16 hocam son bir şey daha sormak istiyorum Resimlerin boyutunu biraz daha büyütmek için ne yapmam gerekir?
 

EmrExcel16

Destek Ekibi
Destek Ekibi
Katılım
1 Kasım 2012
Mesajlar
1,524
Excel Vers. ve Dili
Office 365 Türkçe
Kod:
Selection.Height = .MergeArea.Height + 110
Selection.Width = .MergeArea.Width + 100
Kod' un bu bölümündeki rakamlar ile oynayarak boyutunu değiştirebilirsiniz.
 

zerali

Altın Üye
Katılım
30 Ocak 2013
Mesajlar
368
Excel Vers. ve Dili
2010 türkçe
Altın Üyelik Bitiş Tarihi
27-02-2029
Bilgilendirme için çok sağolun hocam
 
Üst