resimleri sutunlara göre ayarlama

[meda58]

elimde halit3 hocama ait çok güzel bir resim atama makrosu var ancak bu makro tek sutunda calışıyor sutun sayısını çogaltmak istedim ama olmadı

bu makroyu B-D-F-H-K sutunlarında alışaçak şekilde uyarlamak mümkün olurmu
yardımlarınızı bekliyorum

link aşagıdadır

http://www.excel.web.tr/f14/acyklamaya-resim-getirme-d-surucusunden-t108126.html

 

[halit3]

elimde halit3 hocama ait çok güzel bir resim atama makrosu var ancak bu makro tek sutunda calışıyor sutun sayısını çogaltmak istedim ama olmadı

bu makroyu B-D-F-H-K sutunlarında alışaçak şekilde uyarlamak mümkün olurmu
yardımlarınızı bekliyorum

link aşagıdadır

http://www.excel.web.tr/f14/acyklamaya-resim-getirme-d-surucusunden-t108126.html

Yapacağınız işlemlere detaylı açıklamalarınızı içeren örnek bir dosya ekleseydiniz iyi olurdu?

kod:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim hcr As Range
Dim c As Integer
Dim yuk As Double, gen As Double
Range("B:B,D:D,F:F,H:H,K:K").ClearComments
If Intersect(Target, [B:B,D:D,F:F,H:H,K:K]) Is Nothing Then Exit Sub
'If Target.Count > 5 Then Exit Sub
With Cells(Target.Row, Target.Column)
.AddComment
.Comment.Visible = True
.Comment.Shape.Select True
End With
On Error Resume Next
Selection.ShapeRange.Fill.UserPicture "D:\Personel\" & Cells(Target.Row, Target.Column) & ".jpg"
Selection.Height = 100 'yuk
Selection.Width = 100 'gen
Comment.Visible = False
End Sub

 

[meda58]

hocam gerçekten büyüksün çok teşekkürler

 

[meda58]

yalnız hocam sayfayı mutlaka korumaya almalıyım makro korumalı modda çalışmıyor korumalı moddaykaen çalıştırmak mümkünmü

 

[halit3]

yalnız hocam sayfayı mutlaka korumaya almalıyım makro korumalı modda çalışmıyor korumalı moddaykaen çalıştırmak mümkünmü

Şimdi 1 nolu mesajında bu sorunuz yoktu başka bir sorunuz daha olacakmı?

 

[meda58]

hayır hocam başka sorum yok
sayfa korumadayken çalışırsa harika olacak

 

[halit3]

hayır hocam başka sorum yok
sayfa korumadayken çalışırsa harika olacak

kod:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim hcr As Range
Dim c As Integer
Dim yuk As Double, gen As Double
Range("B:B,D:D,F:F,H:H,K:K").ClearComments
If Intersect(Target, [B:B,D:D,F:F,H:H,K:K]) Is Nothing Then Exit Sub
[COLOR=red]Worksheets(ActiveSheet.Name).Protect Password:="[COLOR=blue]123[/COLOR]", Contents:=False, Scenarios:=False[/COLOR]
'If Target.Count > 5 Then Exit Sub
With Cells(Target.Row, Target.Column)
.AddComment
.Comment.Visible = True
.Comment.Shape.Select True
End With
On Error Resume Next
Selection.ShapeRange.Fill.UserPicture "D:\Personel\" & Cells(Target.Row, Target.Column) & ".jpg"
Selection.Height = 100 'yuk
Selection.Width = 100 'gen
Comment.Visible = False
[COLOR=red]Worksheets(ActiveSheet.Name).Protect Password:="[COLOR=blue]123[/COLOR]", Contents:=True, Scenarios:=True
[/COLOR]End Sub