Excel Sayfasına Klasörden Resim Çağırma

[spacebar]

üstad ilginize teşekkür ederim.hem işimi hallettim hem yeni bir şey öğrendim.emeğinize sağlık.

 

[halit3]

üstad örnek çalışmamı ekledim. yardımcı olursanız sevinirim. işimi halletmek için değil yeni bir şey öğrenmek ve başka işlerde uygulayabilmek için istiyorum.teşekkürler...

Alternatif olarak kod:

Private Sub Worksheet_Change(ByVal Target As Range)
sat = Target.Row
sut = Target.Column
If InStr(Trim(ActiveWindow.RangeSelection.Address), ":") = 0 Then
If Target.Row < 4 Then Exit Sub
If Target.Column <> 1 Then Exit Sub
For j = 4 To Val(Target.Row) - 10 Step 10
satir = satir + 10
Next
If sat <> satir + 4 Then Exit Sub
Set Adres = Range(Cells(sat - 2, 3), Cells(sat + 2, 3))
Dim Picture As Object
For Each Picture In ActiveSheet.Shapes
If TypeName(ActiveSheet.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then
If Not Intersect(Range(Picture.TopLeftCell.Address & ":" & Picture.BottomRightCell.Address), Adres) Is Nothing Then
Picture.Delete
Exit For
End If
End If
Next Picture
If Cells(Target.Row, 1).Value = "" Then Exit Sub
klasor = ThisWorkbook.Path & "\Resimler\"
isim = Cells(sat + 4, sut + 3).Value
On Error Resume Next
If CreateObject("Scripting.FileSystemObject").FileExists(klasor & isim & ".jpg") = True Then
ActiveSheet.Pictures.Insert(klasor & isim & ".jpg").Select
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.Top = Adres.Top + 2
Selection.Left = Adres.Left + 2
Selection.ShapeRange.Height = Adres.Height - 3
Selection.ShapeRange.Width = Adres.Width - 3
End If
End If
Cells(Target.Row, 1).Select
End Sub

Rardan klasörü ve dosyayı çıkartıp deneyin.

Not. dosyanın hemen yanında Resimler klasörü olmalı

 

[spacebar]

üstad, bilgilerinize sağlık. farklı kodlarla çözüm yolunu öğrenmiş oldum. çok teşekkür ederim.