resim çağırma

[mcetinkaya65]

http://www.excel.web.tr/f136/personel-bilgileri-resimli-3-rnek-dosya-t22790.html linkini inceledim.Linnkte verilen örneklere resimleri normal ilave ettim.Fakat kendi proğramıma uyum sağladamadım.Cami görevliliği sayfasında çağrılan isme, resim sayfasında kayıtlı resmin gelmesini sağlayamadım.Selamlar

 

[halit3]

Dosyanız şifreli

 

[mcetinkaya65]

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.

 

[halit3]

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.

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]

Alah zihin açıklığı versin.Allah razı olsun.

 

[vedosta]

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

 

[halit3]

Alah zihin açıklığı versin.Allah razı olsun.

Teşekkürler iyi çalışmalar