• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Hücreye Göre Resim getirme

D

dadas76

Katılım
17 Şubat 2011
Mesajlar
36
Excel Vers. ve Dili
2007
Öncelikle bütün arkadaşlarıma Saygılar,

Benim C sürücümde Resim klasörü var ve de içinde jpg.formatlı resimler var.
İstediğim şu.
Mesela ben bir excel çalışma sayfası açayım. A2 hücresine resmin adını (örneğin mrt1) yazayım B2 hücresine resim gelsin.

Bununla ilgili bir makro yazabilir miyiz acaba. Teklif vereceğiz, yardım ederseniz çok sevinirim. Allah hepinizden razı olsun
 
dadas76' Alıntı:
Öncelikle bütün arkadaşlarıma Saygılar,

Benim C sürücümde Resim klasörü var ve de içinde jpg.formatlı resimler var.
İstediğim şu.
Mesela ben bir excel çalışma sayfası açayım. A2 hücresine resmin adını (örneğin mrt1) yazayım B2 hücresine resim gelsin.

Bununla ilgili bir makro yazabilir miyiz acaba. Teklif vereceğiz, yardım ederseniz çok sevinirim. Allah hepinizden razı olsun
Genişletmek için tıkla ...
Merhaba,

İnceleyiniz.
http://www.excel.web.tr/f59/forum-kurallar-305-t1323.html
 
dadas76' Alıntı:
Öncelikle bütün arkadaşlarıma Saygılar,

Benim C sürücümde Resim klasörü var ve de içinde jpg.formatlı resimler var.
İstediğim şu.
Mesela ben bir excel çalışma sayfası açayım. A2 hücresine resmin adını (örneğin mrt1) yazayım B2 hücresine resim gelsin.

Bununla ilgili bir makro yazabilir miyiz acaba. Teklif vereceğiz, yardım ederseniz çok sevinirim. Allah hepinizden razı olsun
Genişletmek için tıkla ...

merhaba
bu link'teki 1. mesajdaki dosyalar işinizi görür sanırım
 
Çok sağolun hocam, fakat işimi görmedi. düşey ara ile falan yapılabilir mi acaba.
 
Resim ekleme

Hocam resimi ekliyorum. boş excel sayfamı da ekliyorum. Hocam bir yardım ederseniz, büyük bir yükten kurtulmuş olacağım. Allah razı olsun.
 

Ekli dosyalar

Hücreye Resim Getirme

Merhaba,

Aşağıdaki kodların ilgili sayfanın kod bölümünde olmalı.

Kodun içinde kırmızı ile belirlediğim yeri kendinize göre düzenleyiniz.

Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
    
    On Error GoTo Son
    If Intersect(Target, [A:A]) Is Nothing Then Exit Sub
    If Target.Row < 2 Then Exit Sub
    If Target.Value = "" Then Exit Sub
'    ActiveSheet.Pictures.Delete
    Dim Yol     As String, _
        Dosya   As String, _
        p       As Object, _
        t       As Double, _
        l       As Double, _
        w       As Double, _
        h       As Double
    
    Yol = "[B][COLOR=red]C:\ZZZZ\[/COLOR][/B]"
    Dosya = Yol & Target.Value & ".jpg"
    ' inserts a picture and resizes it to fit the TargetCells range
    If Dir(Dosya) = "" Then Exit Sub
    
    ' import picture
    Set p = ActiveSheet.Pictures.Insert(Dosya)
    ' determine positions
    ' With TargetCells
    With Target.Offset(0, 1)
        t = .Top
        l = .Left
        w = .Offset(0, .Columns.Count).Left - .Left
        h = .Offset(.Rows.Count, 0).Top - .Top
    End With
    ' position picture
    With p
        .Top = t
        .Left = l
        .Width = w
        .Height = h
    End With
    Set p = Nothing
Son:
End Sub
 

Ekli dosyalar

Tşk ederim.bir de şu var!!

Şöyle birşey yapmakta mümkün mü acaba. Mesela, A2 hücresine lft yazdım B2 hücresine resim geldi. A2 hücresindeki lft yazısını silip ppt yazdığım zaman, B2 hücresinde hem lft'nin resmi hemde ppt'nin resmi geliyor. acaba A2'deki lft'yi sildiğimizde B2'deki lft resmi de silinemez mi?
Dosta ekte.

Saygılar sunar, çok teşekkür ederim.
 

Ekli dosyalar

Siz sadece A2 hücresine resmin adını, resmide B2 ye mi getirtmek istiyorsunuz.

ben hangi A sütununa resim adını yazsanız yanındaki hücreye de resim gelecek mantığını kurdum.

Eğer tek bir hücrede bu işi yapacaksanız kodun başındaki

Kod: 
'    ActiveSheet.Pictures.Delete

satırındaki tek tırnağı siliniz.
 
Merhaba Nejdet bey,

öncelikle ilgi ve alakanız için çok teşekkür ederim. Yapmak istediğim şu:
Ben A2,A3,A4.......vs. hücrelere resmin adını yazıcam. Yazdığım adların resimlerini de B2,B3,B4 hücrelerine getiricem. bunu yapmak istiyorum. ayrıca resimlerin boyutlarınında aynı olmasını sağlamak istiyorum.

Bir de;
diyelim ki ben A2'ye lft yazdım, B2'ye lft'nin resmi geldi. Bir de baktım ki A2'ye lft değil de ppt yazmam gerekli. lft yerine ppt yazdığım da B2 hücresinde hem lft'nin hem de ppt'nin resmi görünüyor. Tek resim görünmüyor.

Çok sağolun Nejdet hocam. Teklif vericez o yüzden böyle zor durumdayız. bunun gibi binlerce kodlu ürün var. Acaba çok mu fazla soru sordum Nejdet hocam.
 
Hücreye Resim Getirme

Merhaba,

aşağıdaki kodda kırmızı ile belirlediğim değişiklikleri ekledim.
B sütununa resmin adını yazdırdım. Bunun görünmesini istemezseniz b sütununun rengini beyaz yapabilirsiniz. Buna göre daha önce resim varsa onu siliyor.

deneyiniz.

Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
    
    On Error GoTo Son
    If Intersect(Target, [A:A]) Is Nothing Then Exit Sub
    If Target.Row < 2 Then Exit Sub
    If Target.Value = "" Then Exit Sub
'    ActiveSheet.Pictures.Delete
    Dim Yol     As String, _
        Dosya   As String, _
        p       As Object, _
        t       As Double, _
        l       As Double, _
        w       As Double, _
        h       As Double
    
    Yol = "C:\ZZZZ\"
    Dosya = Yol & Target.Value & ".jpg"
    ' inserts a picture and resizes it to fit the TargetCells range
    If Dir(Dosya) = "" Then Exit Sub
    
    [COLOR=red][B]If Target.Offset(0, 1) > "" Then ActiveSheet.Shapes(Target.Offset(0, 1)).Delete
[/B][/COLOR]    ' import picture
    Set p = ActiveSheet.Pictures.Insert(Dosya)
    ' determine positions
    ' With TargetCells
    With Target.Offset(0, 1)
       [B][COLOR=red] .Value = p.Name
[/COLOR][/B]        t = .Top
        l = .Left
        w = .Offset(0, .Columns.Count).Left - .Left
        h = .Offset(.Rows.Count, 0).Top - .Top
    End With
    ' position picture
    With p
        .Top = t
        .Left = l
        .Width = w
        .Height = h
    End With
    Set p = Nothing
Son:
End Sub
 
Sayın Nejdet hocam günaydın, ilgi ve alakanız için çok teşekkür ederim.
 
Ben teşekkür ederim, güle güle kullanınız.

Not : İlgi = Alaka
 
2011de açılmış bir konu ama başka birşey sormak istiyorum eğer dosyamız ağdaysa nasıl yazacağız bunu?
ağdaki dosyanın dosya yolunu kopyalayım dedim şöyle bişey çıkıyor "\\amdserver\resimler"
bunu sizin dosya yazdığınız yere yazdım ama çalıştıramadım.

İlginiz için teşekkürler
 
yardım

Vermiş olduğunuz kod işime çok yardım teşekkür ederim.
Ançak bir isteğim var resmi sonrasına değilde bi önceki sütüne nasıl getirebilirim birde resim ortalana bilir mi?

Necdet Yeşertener' Alıntı:
Merhaba,

Aşağıdaki kodların ilgili sayfanın kod bölümünde olmalı.

Kodun içinde kırmızı ile belirlediğim yeri kendinize göre düzenleyiniz.

Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
    
    On Error GoTo Son
    If Intersect(Target, [A:A]) Is Nothing Then Exit Sub
    If Target.Row < 2 Then Exit Sub
    If Target.Value = "" Then Exit Sub
'    ActiveSheet.Pictures.Delete
    Dim Yol     As String, _
        Dosya   As String, _
        p       As Object, _
        t       As Double, _
        l       As Double, _
        w       As Double, _
        h       As Double
    
    Yol = "[B][COLOR=red]C:\ZZZZ\[/COLOR][/B]"
    Dosya = Yol & Target.Value & ".jpg"
    ' inserts a picture and resizes it to fit the TargetCells range
    If Dir(Dosya) = "" Then Exit Sub
    
    ' import picture
    Set p = ActiveSheet.Pictures.Insert(Dosya)
    ' determine positions
    ' With TargetCells
    With Target.Offset(0, 1)
        t = .Top
        l = .Left
        w = .Offset(0, .Columns.Count).Left - .Left
        h = .Offset(.Rows.Count, 0).Top - .Top
    End With
    ' position picture
    With p
        .Top = t
        .Left = l
        .Width = w
        .Height = h
    End With
    Set p = Nothing
Son:
End Sub
Genişletmek için tıkla ...
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst