• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

İki Resim Getirme

zerali

Altın Üye
Katılım
30 Ocak 2013
Mesajlar
416
Excel Vers. ve Dili
2010 türkçe
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
 
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
 
EmrExcel16 hocam kodu yapıştırdım ismi değiştirdim ama resim gelmedi yanlış bir şey mi yaptım
 
"Sayfanın" kod bölümüne yapıştırmanız gerekiyor , belki burada karıştırmış olabilirsiniz .
 
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?
 
Rica ederim , öğrenci sayısı önemli değil bu şekilde kullanabilirsiniz.
 
EmrExcel16 hocam son bir şey daha sormak istiyorum Resimlerin boyutunu biraz daha büyütmek için ne yapmam gerekir?
 
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.
 
Bilgilendirme için çok sağolun hocam
 
Geri
Üst