Excel Makro Resim Eklemek

[dodis33]

İyi günler,
Kodların içindeki resim yolunu siz kendi bilgisayarınıza göre ayarlayınız.Run deyip çalıştırdığımda resimleri üst üste yazıyor.Yani diğer resim aynı bölgede gözüküyor bu sefer sanki hiç resim eklenmemiş gibi duruyor.Her satır numarası yazdığımda o hücrenin içine eklenmesini yapamadım.Yardımcı olursanız sevinirim.
Dosyanın indirme link : TIKLA

DİREK KODLARDAN ANLARIM DİYORSANIZ BUYURUN;

Sub ResimGetir()
SonSatir = InputBox("Satırın son sayısını girin")
If SonSatir = "0" Or SonSatir = "" Then End

Rows("1:" & SonSatir).Select
Selection.RowHeight = 95.25
    
Range("A1").Select

Do

ilkAdr = Selection.Address
Adres1 = Right(ilkAdr, Len(ilkAdr) - 3)
On Error Resume Next
ImageName = Range("B" & Adres1).Value

Select Case Len(ImageName)

Case 1
    ImageName = "00000" & ImageName
Case 2
    ImageName = "0000" & ImageName
Case 3
    ImageName = "000" & ImageName
Case 4
    ImageName = "00" & ImageName
Case 5
    ImageName = "0" & ImageName

End Select

Range("A" & Adres1).Select
ActiveSheet.Pictures.Insert("C:\Users\Images\" & ImageName & ".jpg").Select


Selection.ShapeRange.IncrementLeft 3.75
Selection.ShapeRange.IncrementTop 2.25
Selection.ShapeRange.ScaleWidth 0.52, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.ScaleHeight 0.52, msoFalse, msoScaleFromTopLeft

Range("A" & Adres1 + 1).Select
Loop Until Adres1 = SonSatir
End Sub

 

[dodis]

en büyük excel sayfası ama anlayan yok

 

[halit3]

Sayfanın kod bölümüne yapıştır ve B sütunundaki resim isimlerine göre kod çalışıyor.
Yani örnek B2 hücresini sil ve yeniden resim adını yaz enter deyince resim C sutununa gelecektir.

kot :

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [b2:b65536]) Is Nothing Then Exit Sub

yatay = 1  ' bu kadar hücre sağa kayacak
dikey = 0  ' bu kadar hücre aşağıya kayacak

Dim s1
Set s1 = Sheets(ActiveSheet.Name)

If InStr(Trim(ActiveWindow.RangeSelection.Address), ":") = 0 Then
Set Adres = s1.Cells(Target.Row + dikey, Target.Column + yatay)

Dim Picture As Object
For Each Picture In s1.Shapes
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then
Set yer = s1.Cells(Picture.BottomRightCell.Row, Picture.BottomRightCell.Column)
If yer.Address = Adres.Address Then

Picture.Delete
Exit For
End If

End If
Next Picture

ReDim uzanti(11)
uzanti(1) = "bmp":        uzanti(2) = "jpg"
uzanti(3) = "gif":        uzanti(4) = "pcx"
uzanti(5) = "tga":        uzanti(6) = "emf"
uzanti(7) = "abm":        uzanti(7) = "avi"
uzanti(8) = "png":        uzanti(9) = "jpeg"
uzanti(10) = "wmf":       uzanti(11) = "TIFF"


For j = 1 To 11

Dosya = ThisWorkbook.Path & "\" & Target.Value & "." & uzanti(Val(j))
If CreateObject("Scripting.FileSystemObject").FileExists(Dosya) = True Then
ad = s1.Pictures.Insert(Dosya).Name
s1.Shapes(ad).OLEFormat.Object.ShapeRange.LockAspectRatio = msoFalse
s1.Shapes(ad).OLEFormat.Object.Top = Adres.Top + 1
s1.Shapes(ad).OLEFormat.Object.Left = Adres.Left + 1
s1.Shapes(ad).OLEFormat.Object.ShapeRange.Height = Adres.Height - 2
s1.Shapes(ad).OLEFormat.Object.ShapeRange.Width = Adres.Width - 2
s1.Cells(Target.Row + 1, Target.Column).Select

Exit For
End If
Next


End If
End Sub