Excell resim getirme sorgusu

F

finike

Katılım
27 Mart 2006
Mesajlar
43
Excel Vers. ve Dili
Microsoft Office Excel 2016
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$F$5" Then
On Error Resume Next
Resim = Worksheets("RAPOR").Range("F5").Value
yol = ActiveWorkbook.Path
Worksheets("RAPOR").Image2.Picture = LoadPicture(yol & "\Resimler\" & Resim & ".jpg")
End If
End Sub

Yukarıdaki kod ile klasör içindeki resimleri excell tabloma getiriyorum.
resimlerim klasörümde bulunmayan bir resim resim adı yazdığım zaman "Hata.jpg" resim dosyasını göstermesini istiyorum. Yukarıdaki koda nasıl ekleyebilirim.
Teşekkürler.
 
Emir Hüseyin Çoban

Emir Hüseyin Çoban

Destek Ekibi
Destek Ekibi
Katılım
11 Ağustos 2008
Mesajlar
5,892
Excel Vers. ve Dili
Office 2013 Tr - Win10 x64
. . .

Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address <> "$F$5" Then Exit Sub
    
    On Error Resume Next
    yol = ThisWorkbook.Path & "\Resimler\"
    resim = Worksheets("RAPOR").Range("F5").Value & ".jpg"
    
    If Dir(yol & resim) = "" Then
        Worksheets("RAPOR").Image2.Picture = LoadPicture(yol & "Hata.jpg")
        Exit Sub
    Else
        Worksheets("RAPOR").Image2.Picture = LoadPicture(yol & resim)
    End If
    
End Sub
. . .
 
F

finike

Katılım
27 Mart 2006
Mesajlar
43
Excel Vers. ve Dili
Microsoft Office Excel 2016
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address <> "$C$5" Then Exit Sub
On Error Resume Next
yol = ThisWorkbook.Path & "\Resimler\"
Resim = Worksheets("RAPOR").Range("C5").Value & ".jpg"

If Dir(yol & Resim) = "" Then
Worksheets("RAPOR").Image1.Picture = LoadPicture(yol & "YOK.jpg")
Exit Sub
Else
Worksheets("RAPOR").Image1.Picture = LoadPicture(yol & Resim)
End If
'-------------------------------------------------------------------------

If Target.Address <> "$F$5" Then Exit Sub
On Error Resume Next
yol = ThisWorkbook.Path & "\Resimler\"
Resim = Worksheets("RAPOR").Range("F5").Value & ".jpg"

If Dir(yol & Resim) = "" Then
Worksheets("RAPOR").Image2.Picture = LoadPicture(yol & "YOK.jpg")
Exit Sub
Else
Worksheets("RAPOR").Image2.Picture = LoadPicture(yol & Resim)
End If

Buradaki hatam nedir?
ilki çalışıyor ikincisi çalışmıyor.
aynı sayfada 6 adet çalıştırmak istiyorum.
ilginize şimdiden çok teşekkür ederim.
 
Emir Hüseyin Çoban

Emir Hüseyin Çoban

Destek Ekibi
Destek Ekibi
Katılım
11 Ağustos 2008
Mesajlar
5,892
Excel Vers. ve Dili
Office 2013 Tr - Win10 x64
. . .

3 tane için bu şekilde. Çoğaltmak için aralığı kopyalayıp, mavi ile belirttiğim kısımları değiştirin.

Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
    ''''''''''   [COLOR="Blue"]1[/COLOR]  '''''''''''''''
    If Target.Address = [COLOR="Blue"]"$C$5"[/COLOR] Then
        On Error Resume Next
        yol = ThisWorkbook.Path & "\Resimler\"
        resim = Worksheets("RAPOR").Range("[COLOR="Blue"]C5[/COLOR]").Value & ".jpg"
        If Dir(yol & resim) = "" Then
            Worksheets("RAPOR").[COLOR="Blue"]Image1[/COLOR].Picture = LoadPicture(yol & "ResimYok.jpg")
            Exit Sub
        Else
            Worksheets("RAPOR").[COLOR="Blue"]Image1[/COLOR].Picture = LoadPicture(yol & resim)
        End If
    End If
    ''''''''''   2  '''''''''''''''
    If Target.Address = "$F$5" Then
        On Error Resume Next
        yol = ThisWorkbook.Path & "\Resimler\"
        resim = Worksheets("RAPOR").Range("F5").Value & ".jpg"
        If Dir(yol & resim) = "" Then
            Worksheets("RAPOR").Image2.Picture = LoadPicture(yol & "ResimYok.jpg")
            Exit Sub
        Else
            Worksheets("RAPOR").Image2.Picture = LoadPicture(yol & resim)
        End If
    End If
    ''''''''''   3  '''''''''''''''
    If Target.Address = "$A$5" Then
        On Error Resume Next
        yol = ThisWorkbook.Path & "\Resimler\"
        resim = Worksheets("RAPOR").Range("A5").Value & ".jpg"
        If Dir(yol & resim) = "" Then
            Worksheets("RAPOR").Image3.Picture = LoadPicture(yol & "ResimYok.jpg")
            Exit Sub
        Else
            Worksheets("RAPOR").Image3.Picture = LoadPicture(yol & resim)
        End If
    End If
    
End Sub
. . .
 
halit3

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,800
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
Alternatif kod

Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)

yol = ThisWorkbook.Path & "\Resimler\"
hucre = Target.Address
Resim = Worksheets("RAPOR").Range(hucre).Value & ".jpg"
'------------------------------------------------------------------------------------

If hucre = [COLOR="Red"]"$C$5"[/COLOR] Then
If CreateObject("Scripting.FileSystemObject").FileExists(yol & Resim) = True Then
Worksheets("RAPOR").Image1.Picture = LoadPicture(yol & Resim)
Else
Worksheets("RAPOR").Image1.Picture = LoadPicture(yol & "YOK.jpg")
End If
End If
'------------------------------------------------------------------------------------

If hucre = [COLOR="red"]"$f$5"[/COLOR] Then
If CreateObject("Scripting.FileSystemObject").FileExists(yol & Resim) = True Then
Worksheets("RAPOR").Image2.Picture = LoadPicture(yol & Resim)
Else
Worksheets("RAPOR").Image2.Picture = LoadPicture(yol & "YOK.jpg")
End If
End If
'------------------------------------------------------------------------------------
If hucre = [COLOR="red"]"$h$5"[/COLOR] Then
If CreateObject("Scripting.FileSystemObject").FileExists(yol & Resim) = True Then
Worksheets("RAPOR").Image3.Picture = LoadPicture(yol & Resim)
Else
Worksheets("RAPOR").Image3.Picture = LoadPicture(yol & "YOK.jpg")
End If
End If

End Sub
 
halit3

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,800
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
İkinci Alternatif kod

Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)

Set Sh = Sheets("RAPOR") 'Sheets(ActiveSheet.Name)
yol = ThisWorkbook.Path & "\Resimler\"
hucre = Target.Address
Resim = Sh.Range(hucre).Value & ".jpg"
Dim fL As Object
Set fL = CreateObject("Scripting.FileSystemObject")

'------------------------------------------------------------------------------------

If hucre = [COLOR="red"]"$C$5"[/COLOR] Then
If fL.FileExists(yol & Resim) = True Then
Sh.Image1.Picture = LoadPicture(yol & Resim)
Else
Sh.Image1.Picture = LoadPicture(yol & "YOK.jpg")
End If
End If
'------------------------------------------------------------------------------------

If hucre = [COLOR="red"]"$f$5"[/COLOR] Then
If fL.FileExists(yol & Resim) = True Then
Sh.Image2.Picture = LoadPicture(yol & Resim)
Else
Sh.Image2.Picture = LoadPicture(yol & "YOK.jpg")
End If
End If
'------------------------------------------------------------------------------------
If hucre = [COLOR="red"]"$h$5"[/COLOR] Then
If fL.FileExists(yol & Resim) = True Then
Sh.Image3.Picture = LoadPicture(yol & Resim)
Else
Sh.Image3.Picture = LoadPicture(yol & "YOK.jpg")
End If
End If

End Sub
 
halit3

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,800
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
Bu kod da farklı bir uygulama
kod kırmızı işaretli hücrelerde çalışmakta ve kırmızı renkli hücrelere yazılan resim adı varsa kod altı adet farklı uzantıli resimi buluyor.

Bulunan resim kırmızı renkli hücreye geliyor.

Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)

If Intersect(Target, [[COLOR="red"]C5:F5:G5:H5:K5:M5[/COLOR]]) Is Nothing Then Exit Sub

Dim s1
Set s1 = Sheets(ActiveSheet.Name)

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

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
say = 6
ReDim uzanti(say)
uzanti(1) = "bmp":   uzanti(2) = "jpg"
uzanti(3) = "gif":   uzanti(4) = "BMP"
uzanti(5) = "JPG":   uzanti(6) = "GİF"

son = 0
For j = 1 To say

Dosya = ThisWorkbook.Path & "\Resimler\" & 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
son = 1
Exit For
End If
Next

If son = 0 Then
Dosya = ThisWorkbook.Path & "\Resimler\" & "YOK.jpg"

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
son = 1

End If
End If

End If
End Sub
 
F

finike

Katılım
27 Mart 2006
Mesajlar
43
Excel Vers. ve Dili
Microsoft Office Excel 2016
Yardımlarınız için çok teşekkür ederim.
 
F

finike

Katılım
27 Mart 2006
Mesajlar
43
Excel Vers. ve Dili
Microsoft Office Excel 2016
Ben bu hücrelere formül atadım formül değerleri değiştiriyor fakat resimlerde güncelleme işlemi olmuyor. Makro formülün değiştirdiği değerlerde güncelleme yapmıyor. Nasıl yapabilirim.
Ben başka sayfada çalışıyorum sayfaya her girdiğimde bu hücreleri kontrol edip güncelleme yapabilir mi ?
 
Emir Hüseyin Çoban

Emir Hüseyin Çoban

Destek Ekibi
Destek Ekibi
Katılım
11 Ağustos 2008
Mesajlar
5,892
Excel Vers. ve Dili
Office 2013 Tr - Win10 x64
. . .

Kodları sayfa aktif olduğunda çalışacak şekilde güncellemek gerekir.
Private Sub Worksheet_Activate() altına yazılarak yapılabilir.

Hücrelere yazdığınız formül nedir.

. . .
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst