Soru Klasörden resim alma

B

blue021433

Katılım
21 Şubat 2007
Mesajlar
24
Excel Vers. ve Dili
Office Professional Plus 2019 Türkçe
Altın Üyelik Bitiş Tarihi
11-01-2025
Arkadaşlar aşağıda ki kodla sadece b2 hücresine ID girince a2 hücresine resim getiriyor.
Benim yapmak istediğim b2:b1000 arası satırlara ID girince aynı şekilde a2:a1000 satırlarına resmi getirmek.
Yaptığım bazı değişikliklerle başarılı olamadım. Oluşan hatalar b3 hücresine veri girdiğimde b2 de ki görselin silinmesi gibi sonuçlar aldım.

Yardımlarınız için şimdiden teşekkür ederim.


Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [b2]) Is Nothing Then Exit Sub
On Error Resume Next
ActiveSheet.DrawingObjects.Delete
Set fso = VBA.CreateObject("scripting.filesystemobject")
resimyolu = "C:\RESİM\" & Range("b2") & ".jpg"
resimsiz = "C:\RESİM\" & "RESİMSİZ.jpg"
If Not fso.fileexists(resimyolu) Then
Set resimyok = ActiveSheet.Pictures.Insert(resimsiz)
With Range("a2")
resimyok.Top = Range("a2").Top
resimyok.Left = Range("a2").Left
resimyok.ShapeRange.LockAspectRatio = msoFalse
resimyok.Height = 112
resimyok.Width = 84
End With
Else
Set Resim = ActiveSheet.Pictures.Insert(resimyolu)
With Range("a2")
Resim.Top = Range("a2").Top
Resim.Left = Range("a2").Left
Resim.ShapeRange.LockAspectRatio = msoFalse
Resim.Height = 112
Resim.Width = 84
End With
End If
End Sub
 
M

metin_0606

Katılım
1 Ağustos 2019
Mesajlar
839
Excel Vers. ve Dili
Türkçe excel 2016
İngilizce excel 2016
Altın Üyelik Bitiş Tarihi
19-10-2021
Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
Son = 3
ReDim uzanti(Son)
uzanti(1) = ".bmp"
uzanti(2) = ".jpg"
uzanti(3) = ".gif"
 
 With Application
    .DisplayAlerts = False: .ScreenUpdating = False: .Calculation = xlCalculationAutomatic
End With
ActiveSheet.DrawingObjects.Delete
Klasor = "C:\RESİM\"

Set fso = CreateObject("Scripting.FileSystemObject")
For i = 1 To Cells(Rows.Count, "b").End(3).Row
isim = Cells(i, 2).Value
deg = 0
For j = 1 To Son
If fso.FileExists(Klasor & isim & uzanti(j)) = True Then
Set pc = ActiveSheet.Pictures.Insert(Klasor & isim & uzanti(j)) '<-- dikkat
With pc '<---
    .Top = Cells(i, 1).Top + 2
    .Left = Cells(i, 1).Left + 2
    .ShapeRange.LockAspectRatio = msoFalse
    .ShapeRange.Height = Cells(i, 1).Height - 4
    .ShapeRange.Width = Cells(i, 1).Width - 4
End With
deg = 1
'Sheets("KONTROL").Range("a8").Select

Exit For
End If
Next
Next

End Sub
 
B

blue021433

Katılım
21 Şubat 2007
Mesajlar
24
Excel Vers. ve Dili
Office Professional Plus 2019 Türkçe
Altın Üyelik Bitiş Tarihi
11-01-2025
metin_0606' Alıntı:
Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
Son = 3
ReDim uzanti(Son)
uzanti(1) = ".bmp"
uzanti(2) = ".jpg"
uzanti(3) = ".gif"

With Application
    .DisplayAlerts = False: .ScreenUpdating = False: .Calculation = xlCalculationAutomatic
End With
ActiveSheet.DrawingObjects.Delete
Klasor = "C:\RESİM\"

Set fso = CreateObject("Scripting.FileSystemObject")
For i = 1 To Cells(Rows.Count, "b").End(3).Row
isim = Cells(i, 2).Value
deg = 0
For j = 1 To Son
If fso.FileExists(Klasor & isim & uzanti(j)) = True Then
Set pc = ActiveSheet.Pictures.Insert(Klasor & isim & uzanti(j)) '<-- dikkat
With pc '<---
    .Top = Cells(i, 1).Top + 2
    .Left = Cells(i, 1).Left + 2
    .ShapeRange.LockAspectRatio = msoFalse
    .ShapeRange.Height = Cells(i, 1).Height - 4
    .ShapeRange.Width = Cells(i, 1).Width - 4
End With
deg = 1
'Sheets("KONTROL").Range("a8").Select

Exit For
End If
Next
Next

End Sub
Genişletmek için tıkla ...
Metin bey çok teşekkür ederim bilginizi paylaştığınız için.
 
kulomer46

kulomer46

Altın Üye
Katılım
23 Mart 2007
Mesajlar
1,514
Excel Vers. ve Dili
Microsoft Office LTSC Professional Plus 2021 - Türkçe
Altın Üyelik Bitiş Tarihi
08-06-2027
Konuyla ilgili alternatif bir kod çalışmasıda aşağıdadır.

Selamlar...

Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
'06.07.2020   11:11

On Error GoTo hata

Application.ScreenUpdating = False

If Intersect(Target, Cells(Target.Row, 2)) Is Nothing Then Exit Sub

satır = Target.Row

uç1:
resimadedi = ActiveSheet.DrawingObjects.Count

For i = 1 To resimadedi

    If ActiveSheet.DrawingObjects(i).Top = Range("A" & satır).Top + 5 Then
        If ActiveSheet.DrawingObjects(i).Left = Range("A" & satır).Left + 5 Then

            ActiveSheet.DrawingObjects(i).Delete
            GoTo uç1

        End If
    End If

    DoEvents

Next

DoEvents

Set fso = VBA.CreateObject("scripting.filesystemobject")

resimyolu = "C:\RESİM\" & Range("b2") & ".jpg"

resimsiz = "C:\RESİM\" & "RESİMSİZ.jpg"

Columns(2).HorizontalAlignment = xlCenter
Columns(2).VerticalAlignment = xlCenter
    
If Columns("A:A").EntireColumn.ColumnWidth < 22 Then Columns("A:A").EntireColumn.ColumnWidth = 22

If Not fso.FileExists(resimyolu) Then

    Set resimyok = ActiveSheet.Pictures.Insert(resimsiz)
        Range("A" & satır).EntireRow.RowHeight = 122
        resimyok.Top = Range("A" & satır).Top + 5
        resimyok.Left = Range("A" & satır).Left + 5
        resimyok.ShapeRange.LockAspectRatio = msoFalse
        resimyok.Height = 112
        resimyok.Width = 84

Else

    Set Resim = ActiveSheet.Pictures.Insert(resimyolu)
        Range("A" & satır).EntireRow.RowHeight = 122
        Resim.Top = Range("A" & satır).Top + 5
        Resim.Left = Range("A" & satır).Left + 5
        Resim.ShapeRange.LockAspectRatio = msoFalse
        Resim.Height = 112
        Resim.Width = 84

End If

Application.ScreenUpdating = True

Exit Sub

hata:

MsgBox "Bir Hata ile karşılaşıldı"
Exit Sub

End Sub
 
B

blue021433

Katılım
21 Şubat 2007
Mesajlar
24
Excel Vers. ve Dili
Office Professional Plus 2019 Türkçe
Altın Üyelik Bitiş Tarihi
11-01-2025
kulomer46' Alıntı:
Konuyla ilgili alternatif bir kod çalışmasıda aşağıdadır.

Selamlar...

Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
'06.07.2020   11:11

On Error GoTo hata

Application.ScreenUpdating = False

If Intersect(Target, Cells(Target.Row, 2)) Is Nothing Then Exit Sub

satır = Target.Row

uç1:
resimadedi = ActiveSheet.DrawingObjects.Count

For i = 1 To resimadedi

    If ActiveSheet.DrawingObjects(i).Top = Range("A" & satır).Top + 5 Then
        If ActiveSheet.DrawingObjects(i).Left = Range("A" & satır).Left + 5 Then

            ActiveSheet.DrawingObjects(i).Delete
            GoTo uç1

        End If
    End If

    DoEvents

Next

DoEvents

Set fso = VBA.CreateObject("scripting.filesystemobject")

resimyolu = "C:\RESİM\" & Range("b2") & ".jpg"

resimsiz = "C:\RESİM\" & "RESİMSİZ.jpg"

Columns(2).HorizontalAlignment = xlCenter
Columns(2).VerticalAlignment = xlCenter
   
If Columns("A:A").EntireColumn.ColumnWidth < 22 Then Columns("A:A").EntireColumn.ColumnWidth = 22

If Not fso.FileExists(resimyolu) Then

    Set resimyok = ActiveSheet.Pictures.Insert(resimsiz)
        Range("A" & satır).EntireRow.RowHeight = 122
        resimyok.Top = Range("A" & satır).Top + 5
        resimyok.Left = Range("A" & satır).Left + 5
        resimyok.ShapeRange.LockAspectRatio = msoFalse
        resimyok.Height = 112
        resimyok.Width = 84

Else

    Set Resim = ActiveSheet.Pictures.Insert(resimyolu)
        Range("A" & satır).EntireRow.RowHeight = 122
        Resim.Top = Range("A" & satır).Top + 5
        Resim.Left = Range("A" & satır).Left + 5
        Resim.ShapeRange.LockAspectRatio = msoFalse
        Resim.Height = 112
        Resim.Width = 84

End If

Application.ScreenUpdating = True

Exit Sub

hata:

MsgBox "Bir Hata ile karşılaşıldı"
Exit Sub

End Sub
Genişletmek için tıkla ...
Merhaba kulomer46,

Gönderdiğiniz kod ile a2 hücresine gelen ilk görsel diğer satırlara da aynısı gelmekte.
Örnek: b2 hücresine ID-1'e karşılık a2 hücresine 1.jpeg geliyor
b3 hücresine ID-2 yazdığımda a3 hücresine yine 1.jpeg gelmekte.
 
kulomer46

kulomer46

Altın Üye
Katılım
23 Mart 2007
Mesajlar
1,514
Excel Vers. ve Dili
Microsoft Office LTSC Professional Plus 2021 - Türkçe
Altın Üyelik Bitiş Tarihi
08-06-2027
Merhaba

Bahsettiğiniz soruna neden olan kodlardaki hatayı düzelttim. Kodların son hali aşağıdadır.

resimyolu = "C:\RESİM\" & Range("b2") & ".jpg" satırını çıkartıp yerine
resimyolu = "C:\RESİM\" & Cells(Target.Row, 2) & ".jpg" satırını ekledim

Selamlar...

Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
'06.07.2020   11:11

On Error GoTo hata

Application.ScreenUpdating = False

If Intersect(Target, Cells(Target.Row, 2)) Is Nothing Then Exit Sub

'ActiveSheet.DrawingObjects.Delete

satır = Target.Row

uç1:
resimadedi = ActiveSheet.DrawingObjects.Count

For i = 1 To resimadedi

    If ActiveSheet.DrawingObjects(i).Top = Range("A" & satır).Top + 5 Then
        If ActiveSheet.DrawingObjects(i).Left = Range("A" & satır).Left + 5 Then

            ActiveSheet.DrawingObjects(i).Delete
            GoTo uç1

        End If
    End If
  
    DoEvents

Next

DoEvents

Set fso = VBA.CreateObject("scripting.filesystemobject")

resimyolu = "C:\RESİM\" & Cells(Target.Row, 2) & ".jpg"

resimsiz = "C:\RESİM\" & "RESİMSİZ.jpg"

Columns(2).HorizontalAlignment = xlCenter
Columns(2).VerticalAlignment = xlCenter
      
If Columns("A:A").EntireColumn.ColumnWidth < 22 Then Columns("A:A").EntireColumn.ColumnWidth = 22

If Not fso.FileExists(resimyolu) Then

    Set resimyok = ActiveSheet.Pictures.Insert(resimsiz)
        Range("A" & satır).EntireRow.RowHeight = 122
        resimyok.Top = Range("A" & satır).Top + 5
        resimyok.Left = Range("A" & satır).Left + 5
        resimyok.ShapeRange.LockAspectRatio = msoFalse
        resimyok.Height = 112
        resimyok.Width = 84
  
Else

    Set Resim = ActiveSheet.Pictures.Insert(resimyolu)
        Range("A" & satır).EntireRow.RowHeight = 122
        Resim.Top = Range("A" & satır).Top + 5
        Resim.Left = Range("A" & satır).Left + 5
        Resim.ShapeRange.LockAspectRatio = msoFalse
        Resim.Height = 112
        Resim.Width = 84

End If

Application.ScreenUpdating = True

Exit Sub


hata:

MsgBox "Bir Hata ile karşılaşıldı"
Exit Sub

End Sub
 
Son düzenleme:
B

blue021433

Katılım
21 Şubat 2007
Mesajlar
24
Excel Vers. ve Dili
Office Professional Plus 2019 Türkçe
Altın Üyelik Bitiş Tarihi
11-01-2025
kulomer46' Alıntı:
Merhaba

Bahsettiğiniz soruna neden olan kodlardaki hatayı düzelttim. Kodların son hali aşağıdadır.

Selamlar...

Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
'06.07.2020   11:11

On Error GoTo hata

Application.ScreenUpdating = False

If Intersect(Target, Cells(Target.Row, 2)) Is Nothing Then Exit Sub

'ActiveSheet.DrawingObjects.Delete

satır = Target.Row

uç1:
resimadedi = ActiveSheet.DrawingObjects.Count

For i = 1 To resimadedi

    If ActiveSheet.DrawingObjects(i).Top = Range("A" & satır).Top + 5 Then
        If ActiveSheet.DrawingObjects(i).Left = Range("A" & satır).Left + 5 Then

            ActiveSheet.DrawingObjects(i).Delete
            GoTo uç1

        End If
    End If
  
    DoEvents

Next

DoEvents

Set fso = VBA.CreateObject("scripting.filesystemobject")

resimyolu = "C:\RESİM\" & Cells(Target.Row, 2) & ".jpg"

resimsiz = "C:\RESİM\" & "RESİMSİZ.jpg"

Columns(2).HorizontalAlignment = xlCenter
Columns(2).VerticalAlignment = xlCenter
      
If Columns("A:A").EntireColumn.ColumnWidth < 22 Then Columns("A:A").EntireColumn.ColumnWidth = 22

If Not fso.FileExists(resimyolu) Then

    Set resimyok = ActiveSheet.Pictures.Insert(resimsiz)
        Range("A" & satır).EntireRow.RowHeight = 122
        resimyok.Top = Range("A" & satır).Top + 5
        resimyok.Left = Range("A" & satır).Left + 5
        resimyok.ShapeRange.LockAspectRatio = msoFalse
        resimyok.Height = 112
        resimyok.Width = 84
  
Else

    Set Resim = ActiveSheet.Pictures.Insert(resimyolu)
        Range("A" & satır).EntireRow.RowHeight = 122
        Resim.Top = Range("A" & satır).Top + 5
        Resim.Left = Range("A" & satır).Left + 5
        Resim.ShapeRange.LockAspectRatio = msoFalse
        Resim.Height = 112
        Resim.Width = 84

End If

Application.ScreenUpdating = True

Exit Sub


hata:

MsgBox "Bir Hata ile karşılaşıldı"
Exit Sub

End Sub
Genişletmek için tıkla ...
Çok teşekkürler, Kod sorunsuz çalışmakta.
 
kulomer46

kulomer46

Altın Üye
Katılım
23 Mart 2007
Mesajlar
1,514
Excel Vers. ve Dili
Microsoft Office LTSC Professional Plus 2021 - Türkçe
Altın Üyelik Bitiş Tarihi
08-06-2027
Merhaba

Kodların aşağıdaki son hali çıkabilecek bazı pürüzleri de engellemektedir.

Selamlar...


Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
'06.07.2020   11:11

On Error GoTo hata

Application.ScreenUpdating = False

If Intersect(Target, Cells(Target.Row, 2)) Is Nothing Then Exit Sub

'ActiveSheet.DrawingObjects.Delete

satır = Target.Row

uç1:
resimadedi = ActiveSheet.DrawingObjects.Count

For i = 1 To resimadedi

    If ActiveSheet.DrawingObjects(i).Top >= Range("A" & satır).Top + 4 And ActiveSheet.DrawingObjects(i).Top <= Range("A" & satır).Top + 6 Then
      If ActiveSheet.DrawingObjects(i).Left >= Range("A" & satır).Left + 4 And ActiveSheet.DrawingObjects(i).Left <= Range("A" & satır).Left + 6 Then

            ActiveSheet.DrawingObjects(i).Delete
            GoTo uç1

        End If
    End If
    
    DoEvents

Next

DoEvents

Set fso = VBA.CreateObject("scripting.filesystemobject")

resimyolu = "C:\RESİM\" & Cells(Target.Row, 2) & ".jpg"

resimsiz = "C:\RESİM\" & "RESİMSİZ.jpg"

Columns(2).HorizontalAlignment = xlCenter
Columns(2).VerticalAlignment = xlCenter
      
If Columns("A:A").EntireColumn.ColumnWidth < 22 Then Columns("A:A").EntireColumn.ColumnWidth = 22

If Not fso.FileExists(resimyolu) Then

    Set resimyok = ActiveSheet.Pictures.Insert(resimsiz)
        Range("A" & satır).EntireRow.RowHeight = 122
        resimyok.Top = Range("A" & satır).Top + 5
        resimyok.Left = Range("A" & satır).Left + 5
        resimyok.ShapeRange.LockAspectRatio = msoFalse
        resimyok.Height = 112
        resimyok.Width = 84
 
Else

    Set Resim = ActiveSheet.Pictures.Insert(resimyolu)
        Range("A" & satır).EntireRow.RowHeight = 122
        Resim.Top = Range("A" & satır).Top + 5
        Resim.Left = Range("A" & satır).Left + 5
        Resim.ShapeRange.LockAspectRatio = msoFalse
        Resim.Height = 112
        Resim.Width = 84

End If

Application.ScreenUpdating = True

Exit Sub


hata:

MsgBox "Bir Hata ile karşılaşıldı"
Exit Sub

End Sub
 
B

blue021433

Katılım
21 Şubat 2007
Mesajlar
24
Excel Vers. ve Dili
Office Professional Plus 2019 Türkçe
Altın Üyelik Bitiş Tarihi
11-01-2025
kulomer46' Alıntı:
Merhaba

Kodların aşağıdaki son hali çıkabilecek bazı pürüzleri de engellemektedir.

Selamlar...


Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
'06.07.2020   11:11

On Error GoTo hata

Application.ScreenUpdating = False

If Intersect(Target, Cells(Target.Row, 2)) Is Nothing Then Exit Sub

'ActiveSheet.DrawingObjects.Delete

satır = Target.Row

uç1:
resimadedi = ActiveSheet.DrawingObjects.Count

For i = 1 To resimadedi

    If ActiveSheet.DrawingObjects(i).Top >= Range("A" & satır).Top + 4 And ActiveSheet.DrawingObjects(i).Top <= Range("A" & satır).Top + 6 Then
      If ActiveSheet.DrawingObjects(i).Left >= Range("A" & satır).Left + 4 And ActiveSheet.DrawingObjects(i).Left <= Range("A" & satır).Left + 6 Then

            ActiveSheet.DrawingObjects(i).Delete
            GoTo uç1

        End If
    End If
   
    DoEvents

Next

DoEvents

Set fso = VBA.CreateObject("scripting.filesystemobject")

resimyolu = "C:\RESİM\" & Cells(Target.Row, 2) & ".jpg"

resimsiz = "C:\RESİM\" & "RESİMSİZ.jpg"

Columns(2).HorizontalAlignment = xlCenter
Columns(2).VerticalAlignment = xlCenter
     
If Columns("A:A").EntireColumn.ColumnWidth < 22 Then Columns("A:A").EntireColumn.ColumnWidth = 22

If Not fso.FileExists(resimyolu) Then

    Set resimyok = ActiveSheet.Pictures.Insert(resimsiz)
        Range("A" & satır).EntireRow.RowHeight = 122
        resimyok.Top = Range("A" & satır).Top + 5
        resimyok.Left = Range("A" & satır).Left + 5
        resimyok.ShapeRange.LockAspectRatio = msoFalse
        resimyok.Height = 112
        resimyok.Width = 84

Else

    Set Resim = ActiveSheet.Pictures.Insert(resimyolu)
        Range("A" & satır).EntireRow.RowHeight = 122
        Resim.Top = Range("A" & satır).Top + 5
        Resim.Left = Range("A" & satır).Left + 5
        Resim.ShapeRange.LockAspectRatio = msoFalse
        Resim.Height = 112
        Resim.Width = 84

End If

Application.ScreenUpdating = True

Exit Sub


hata:

MsgBox "Bir Hata ile karşılaşıldı"
Exit Sub

End Sub
Genişletmek için tıkla ...
Tekrardan teşekkürler, Gönderdiğiniz kodların son halini denedim sorunsuz çalışmakta.
 
B

blue021433

Katılım
21 Şubat 2007
Mesajlar
24
Excel Vers. ve Dili
Office Professional Plus 2019 Türkçe
Altın Üyelik Bitiş Tarihi
11-01-2025
kulomer46' Alıntı:
Kolay gelsin. Dönüş için teşekkürler.

Selamlar...
Genişletmek için tıkla ...
Sizden bir ricam daha olacak, bu kodlara ilaveten sayfa2 den veri çekebilir miyiz ? =düşeyara gibi.
Örnekleme verirsek; b2 hücresine ID verdiğim zaman a2 hücresine resim geliyordu, c,d,e ve f sütünlarına sayfa2 veri alma.
Sayfa2 a hücresinde ID yazmakta
sayfa2 b sütunu sayfa1 c ye gelecek
sayfa2 c sütunu sayfa1 d ye gelecek
sayfa2 d sütunu sayfa1 e ye gelecek
sayfa2 e sütunu sayfa1 f ye gelecek şekilde. :)
 
kulomer46

kulomer46

Altın Üye
Katılım
23 Mart 2007
Mesajlar
1,514
Excel Vers. ve Dili
Microsoft Office LTSC Professional Plus 2021 - Türkçe
Altın Üyelik Bitiş Tarihi
08-06-2027
Merhaba

Talebinizi tam olarak anlayamadım.

Selamlar...
 
B

blue021433

Katılım
21 Şubat 2007
Mesajlar
24
Excel Vers. ve Dili
Office Professional Plus 2019 Türkçe
Altın Üyelik Bitiş Tarihi
11-01-2025
Merhaba,
Sizin vermiş olduğunuz kodlamada b2 hücresine ID yazdığım zaman o ID ye ait a2 hücresine resim gelmekte.
Aynı şekilde b2 hücresine yazdığım ID numarasına ait sayfa2 de veriler var onlarında gelmesini istiyorum.
 
kulomer46

kulomer46

Altın Üye
Katılım
23 Mart 2007
Mesajlar
1,514
Excel Vers. ve Dili
Microsoft Office LTSC Professional Plus 2021 - Türkçe
Altın Üyelik Bitiş Tarihi
08-06-2027
blue021433' Alıntı:
Merhaba,
Sizin vermiş olduğunuz kodlamada b2 hücresine ID yazdığım zaman o ID ye ait a2 hücresine resim gelmekte.
Aynı şekilde b2 hücresine yazdığım ID numarasına ait sayfa2 de veriler var onlarında gelmesini istiyorum.
Genişletmek için tıkla ...
Merhaba

Yukardaki taleplerinizi karşılayan kodlar aşağıdadır.

Selamlar...

Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
'06.07.2020   11:11

On Error GoTo hata

Application.ScreenUpdating = False

If Intersect(Target, Cells(Target.Row, 2)) Is Nothing Then Exit Sub

'ActiveSheet.DrawingObjects.Delete

satır = Target.Row

uç1:
resimadedi = ActiveSheet.DrawingObjects.Count

For i = 1 To resimadedi

    If ActiveSheet.DrawingObjects(i).Top >= Range("A" & satır).Top + 4 And ActiveSheet.DrawingObjects(i).Top <= Range("A" & satır).Top + 6 Then
      If ActiveSheet.DrawingObjects(i).Left >= Range("A" & satır).Left + 4 And ActiveSheet.DrawingObjects(i).Left <= Range("A" & satır).Left + 6 Then

            ActiveSheet.DrawingObjects(i).Delete
            GoTo uç1

        End If
    End If
   
    DoEvents

Next

DoEvents

Set fso = VBA.CreateObject("scripting.filesystemobject")

resimyolu = "C:\RESİM\" & Cells(Target.Row, 2) & ".jpg"

resimsiz = "C:\RESİM\" & "RESİMSİZ.jpg"

Columns(2).HorizontalAlignment = xlCenter
Columns(2).VerticalAlignment = xlCenter
     
If Columns("A:A").EntireColumn.ColumnWidth < 22 Then Columns("A:A").EntireColumn.ColumnWidth = 22

If Not fso.FileExists(resimyolu) Then

    Set resimyok = ActiveSheet.Pictures.Insert(resimsiz)
        Range("A" & satır).EntireRow.RowHeight = 122
        resimyok.Top = Range("A" & satır).Top + 5
        resimyok.Left = Range("A" & satır).Left + 5
        resimyok.ShapeRange.LockAspectRatio = msoFalse
        resimyok.Height = 112
        resimyok.Width = 84

Else

    Set Resim = ActiveSheet.Pictures.Insert(resimyolu)
        Range("A" & satır).EntireRow.RowHeight = 122
        Resim.Top = Range("A" & satır).Top + 5
        Resim.Left = Range("A" & satır).Left + 5
        Resim.ShapeRange.LockAspectRatio = msoFalse
        Resim.Height = 112
        Resim.Width = 84

End If

        Target.Offset(0, 1) = ""
        Target.Offset(0, 2) = ""
        Target.Offset(0, 3) = ""
        Target.Offset(0, 4) = ""

For h = 1 To Sheets("Sayfa2").Cells(Rows.Count, 1).End(3).Row

    If Target.Value = Sheets("Sayfa2").Cells(h, 1) Then
   
        Target.Offset(0, 1) = Sheets("Sayfa2").Cells(h, 2)
        Target.Offset(0, 2) = Sheets("Sayfa2").Cells(h, 3)
        Target.Offset(0, 3) = Sheets("Sayfa2").Cells(h, 4)
        Target.Offset(0, 4) = Sheets("Sayfa2").Cells(h, 5)
        GoTo bitti
   
    End If

Next

bitti:


Application.ScreenUpdating = True

Exit Sub


hata:

MsgBox "Bir Hata ile karşılaşıldı"
Exit Sub

End Sub
 
B

blue021433

Katılım
21 Şubat 2007
Mesajlar
24
Excel Vers. ve Dili
Office Professional Plus 2019 Türkçe
Altın Üyelik Bitiş Tarihi
11-01-2025
Merhaba,

Yine b2 hücresine veri girdiğimde sadece a2 hücresine resim gelmekte. sayfa2 den verileri almıyor. Belki de ben tam olarak anlatamadım.
Sayfa2 de A,B,C,D ve E sütunlarında ürün bilgilerim var.
Sayfa1 b2 hücresine veri girdiğimde sayfa2 b sütununda ki veri Sayfa1 c sütununa gelmesini sağlamak istiyorum.
Örnek dosya ektedir.
 

Ekli dosyalar

kulomer46

kulomer46

Altın Üye
Katılım
23 Mart 2007
Mesajlar
1,514
Excel Vers. ve Dili
Microsoft Office LTSC Professional Plus 2021 - Türkçe
Altın Üyelik Bitiş Tarihi
08-06-2027
Merhaba

Dosyanızı indirdim ve inceledim.
Kodları eklediğim dosyanızın son hali Ek 'tedir.
Bende sorunsuz çalışıyor.

Selamlar...
 

Ekli dosyalar

B

blue021433

Katılım
21 Şubat 2007
Mesajlar
24
Excel Vers. ve Dili
Office Professional Plus 2019 Türkçe
Altın Üyelik Bitiş Tarihi
11-01-2025
Sorunu şimdi anladım,

Siz 2. sayfadan veri çekmeyi resim yolundan göstermişsiniz muhtemelen.
Bunu resimden değilde kod kısmından veri çekmeyi yapabilir miyiz ? Çünkü ürün görseli olmayan satırlarım var.
 
kulomer46

kulomer46

Altın Üye
Katılım
23 Mart 2007
Mesajlar
1,514
Excel Vers. ve Dili
Microsoft Office LTSC Professional Plus 2021 - Türkçe
Altın Üyelik Bitiş Tarihi
08-06-2027
blue021433' Alıntı:
Sorunu şimdi anladım,

Siz 2. sayfadan veri çekmeyi resim yolundan göstermişsiniz muhtemelen.
Bunu resimden değilde kod kısmından veri çekmeyi yapabilir miyiz ? Çünkü ürün görseli olmayan satırlarım var.
Genişletmek için tıkla ...
Merhaba

Dosya bende düzgün çalışmaktadır. Şu andaki haliyle veri çekme kod kısmından yapılmaktadır.

selamlar...
 
B

blue021433

Katılım
21 Şubat 2007
Mesajlar
24
Excel Vers. ve Dili
Office Professional Plus 2019 Türkçe
Altın Üyelik Bitiş Tarihi
11-01-2025
Merhaba,

Evet ürün görseli varsa düzgün çalışıyor, fakat ürün görseli yoksa Bir Hata ile karşılaşıldı uyarısı verdiğinde ürün bilgileri gelmiyor.
Ürün görseli olmasa bile veriler gelsin olabilir mi.
Bunun çözümü var mıdır ?
Uğraştırdım size fazlasıyla :)
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst