• DİKKAT

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

resim çağırma

mcetinkaya65

Altın Üye
Katılım
1 Mart 2011
Mesajlar
490
Excel Vers. ve Dili
2021 türkçe

Ekli dosyalar

Dosyanız şifreli
 
Değerli hocam,
Özür dilerim dosyayı şifreli göndermişim.Cami görevliliği sayfasından çağırdığımız ismin resmininde resim sayfasından istenilen hücreye gelmesi mümkün mü?
Saygılarımla.
 

Ekli dosyalar

Değerli hocam,
Özür dilerim dosyayı şifreli göndermişim.Cami görevliliği sayfasından çağırdığımız ismin resmininde resim sayfasından istenilen hücreye gelmesi mümkün mü?
Saygılarımla.

Bu kodu açılan liste kutusuna bağlayın

not : resim sayfasındaki resimler hücreyi taşmıyacak büyüklükte olması gerekiyor aksi taktirde işlem yapmıyor.

Kod:
Sub resimekle()
sat1 = 16
sat2 = 23
sut1 = 17
sut2 = 18
Dim Picturer As Object
Set Adres = Range(Cells(sat1, sut1).Address, Cells(sat2, sut2).Address)
Dim Picture As Object
For Each Picture In ActiveSheet.Shapes
If Not Intersect(Range(Picture.TopLeftCell.Address & ":" & Picture.BottomRightCell.Address), Adres) Is Nothing Then
Picture.Delete
End If
Next Picture

sat = Sheets("CAMİ GÖREVLİLİĞİ").Cells(1, 1).Value + 1
Adres2 = Sheets("Resim").Cells(sat, 2).Address
For Each Picture In Sheets("Resim").Shapes
If Picture.BottomRightCell.Address = Adres2 Then
Sheets("Resim").Shapes(Picture.Name).CopyPicture
Range("Q16").Select
Sheets("CAMİ GÖREVLİLİĞİ").Paste

End If
Next Picture
For Each Picturer In ActiveSheet.Shapes
If Not Intersect(Range(Picturer.TopLeftCell.Address & ":" & Picturer.BottomRightCell.Address), Adres) Is Nothing Then
ad = Picturer.Name
ActiveSheet.Shapes(ad).OLEFormat.Object.Select
ActiveSheet.Shapes(ad).OLEFormat.Object.Top = Adres.Top
ActiveSheet.Shapes(ad).OLEFormat.Object.Left = Adres.Left
ActiveSheet.Shapes(ad).OLEFormat.Object.ShapeRange.LockAspectRatio = msoFalse
ActiveSheet.Shapes(ad).OLEFormat.Object.ShapeRange.Height = Adres.Height
ActiveSheet.Shapes(ad).OLEFormat.Object.ShapeRange.Width = Adres.Width
Range("Q16").Select
End If
Next Picturer
End Sub
 
mcetinkaya65 sana hazırladığın "cami Görevliliği" dosyan için, halit3 hocama da yazdığı kod için çok teşekkür ederim. Tam aradığım gibi. Allah her ikinizden de razı olsun
 
Geri
Üst