Çözüldü Resim makrosu sorunu.

[bycakir]

merhabalar,

öncelikle düşüncemi aktarayım.

istediğim . excelde personel kayıtlarını ekledikce son satırda yazdığım sicil numarasına göre son eklenen personelin resmini görmek istiyorum. bunu aşağıdaki kod ile yaptım. fakat şöyle bir sorunum oluştu her satır daki sicilin resmini alıyor üst üste ekliyor en son resmi getiriyor. benim istediğim son eklenen sicile göre resim getirsin bir öncekini silsin "
For satır = 3 To 6000
"bu yerden şüphelenmekteyim. yardımlarınızı beklemekteyim.

Private Sub Worksheet_Change(ByVal Target As Range)

If Intersect(Target, [E:E]) Is Nothing Then Exit Sub

'hata kontrolü
On Error Resume Next


'Resimleri Sil

ActiveSheet.DrawingObjects.Delete

'Resim yolunun bulunması

Dim ResimYolu As Variant
Dim Resim As Object

For satır = 3 To 6000


ResimYolu = "\\Share\revir$\PERSONEL_RESIMLERI\Güncel resimler (silinmeyecek)\" & Range("e" & satır) & ".jpg"

'Resmi oluştur
Set Resim = ActiveSheet.Pictures.Insert(ResimYolu)

'Resmi boyutlandır

With Range("C1")
Resim.Top = .Top
Resim.Left = .Left
Resim.Height = .Height
Resim.Width = .Width
End With

Next



    With Target
        If .Row < 1 Then Exit Sub
        .Offset(1, -2) = ""
        If .Value = "" Then Exit Sub
        .Offset(0, -2) = Date
               
         End With
   

    With Target
        If .Row < 1 Then Exit Sub
        .Offset(1, -1) = ""
        If .Value = "" Then Exit Sub
        .Offset(0, -1) = Time
         
    End With

End Sub

 

[turist]

Kodunuzu aşağıdaki gibi uygulayıp , deneyin.

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [E:E]) Is Nothing Then Exit Sub
'hata kontrolü
On Error Resume Next
'Resimleri Sil
ActiveSheet.DrawingObjects.Delete
'Resim yolunun bulunması
Dim ResimYolu As Variant
Dim Resim As Object
ResimYolu = "\\Share\revir$\PERSONEL_RESIMLERI\Güncel resimler (silinmeyecek)\" & Range("e" & Cells(Rows.Count, "E").End(3).Row) & ".jpg"
'Resmi oluştur
Set Resim = ActiveSheet.Pictures.Insert(ResimYolu)
'Resmi boyutlandır
With Range("C1")
Resim.Top = .Top
Resim.Left = .Left
Resim.Height = .Height
Resim.Width = .Width
End With
    With Target
        If .Row < 1 Then Exit Sub
        .Offset(1, -2) = ""
        If .Value = "" Then Exit Sub
        .Offset(0, -2) = Date
         End With
    With Target
        If .Row < 1 Then Exit Sub
        .Offset(1, -1) = ""
        If .Value = "" Then Exit Sub
        .Offset(0, -1) = Time
    End With
End Sub

 

[bycakir]

sorunum çözüldü teşekkürler.

 

[turist]

Sağolun.