açıklamaya göre resim ekleme revize kod.

[zahitsen]

Arkadaşlar elimdeki kodla bulunduğum satırın son sutununda bulunan hücrenin açıklmasına resim geliyor ben ise şimdi resmin açıklama olarak geleceği hücreyi b sutunu olarak sabitlemek istiyorum yardımınıza ihtiyacım var.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim yuk As Double, gen As Double




SON = Worksheets(ActiveSheet.Name).Cells(1, Columns.Count).End(xlToLeft).Column

Columns(SON).ClearComments
If InStr(Target.Address, ":") > 0 Or InStr(Target.Address, ",") > 0 Then Exit Sub
If Target.Value = "" Then Exit Sub
With Cells(Target.Row, SON)
.AddComment
.Comment.Visible = True
.Comment.Shape.Select True
End With
On Error Resume Next
Selection.ShapeRange.Fill.UserPicture ThisWorkbook.Path & "\Ürün Kodları ve Resimler\" & Cells(Target.Row, SON) & ".jpg"
Selection.Height = 350 'yuk
Selection.Width = 450 'gen

If ActiveCell.Top - ActiveWindow.VisibleRange.Top + Selection.Height > ActiveWindow.VisibleRange.Height Then
Selection.Top = Selection.Top - Selection.Height

End If



Target.Select

End Sub

 

[turist]

SON = Worksheets(ActiveSheet.Name).Cells(1, Columns.Count).End(xlToLeft)

yerine

SON = 2

yazarak deneyin

 

[zahitsen]

yardımınız için teşekkürler birde şoyle bir problemim var 2 sutunda çok fazla satır olduğu için ağır çalışıyor ben onu 2 sutun ilk 250 satıra göre ayarlama yapmak istiyorum.

 

[turist]

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim yuk As Double, gen As Double
Application.ScreenUpdating = False
Columns(2).ClearComments
If Not Intersect(Target, Range("A1:B250")) Is Nothing Then
If InStr(Target.Address, ":") > 0 Or InStr(Target.Address, ",") > 0 Then Exit Sub
If Target.Value = "" Then Exit Sub
With Cells(Target.Row, 2)
.AddComment
.Comment.Visible = True
.Comment.Shape.Select True
End With
On Error Resume Next
Selection.ShapeRange.Fill.UserPicture ThisWorkbook.Path & "\Ürün Kodları ve Resimler\" & Cells(Target.Row, 2) & ".jpg"
Selection.Height = 350 'yuk
Selection.Width = 450 'gen
If ActiveCell.Top - ActiveWindow.VisibleRange.Top + Selection.Height > ActiveWindow.VisibleRange.Height Then
Selection.Top = Selection.Top - Selection.Height
End If
End If
Target.Select
Application.ScreenUpdating = True
End Sub

şeklinde deneyin.