MAcro ile Excel'e resim çekme sorunu

[ethem.belen]

Merhaba arkadaşlar, Bir üretim firmasında çalışıyorum. Nerdeyse bütün günüm excele resim yapıştırmakla geçiyor. Ekte bir excel dosyası ve bir klasör(Resim) ekledim. Resim klasöründeki resimleri excel dosyasındaki belirtiğim yere sadece üst kısımdaki yere ürün kodunu yazarak ürün resmini excel cekmem gerekiyor. Yapılmaış bir örnek var fakat diğer kutucuklarada aynı mantıkta resim çekebilmem gerekiyor. Yardımcı olabilirseniz çok müteşekkir olurum. Şimdiden teşekkürler..

 

[Levent Menteşoğlu]

Eklediğiniz dosya hatalıdır, tekrar ekleyiniz.

 

[Merhum İdris SERDAR]

.

Dosyanız açılmıyor.

Buradaki dosyaları inceleyin.

http://www.excel.web.tr/showthread.php?t=22790

.

 

[ethem.belen]

Merhaba arkadaşlar, Bir üretim firmasında çalışıyorum. Nerdeyse bütün günüm excele resim yapıştırmakla geçiyor. Ekte bir excel dosyası ve bir klasör(Resim) ekledim. Resim klasöründeki resimleri excel dosyasındaki belirtiğim yere sadece üst kısımdaki yere ürün kodunu yazarak ürün resmini excel cekmem gerekiyor. Yapılmaış bir örnek var fakat diğer kutucuklarada aynı mantıkta resim çekebilmem gerekiyor. Yardımcı olabilirseniz çok müteşekkir olurum. Şimdiden teşekkürler...
AÇILABİLİR FORMATI EKLEDİM TEŞEKKÜRLER

 

[ethem.belen]

Makro konusunda yardımcı olabilecek arkadaşımız yok galiba

 

[Evolver]

ethem bey

aşağıdaki kodları sayfa1 in kod bölümüne yapıştırın ve resimlerin yolunu kendinize göre ayarlayın.
kodu çalıştırdığınızda resimlerin eklendiğini göreceksiniz
ama hiçbir denetim yaptırmadım
mesela resimlerin ebatları büyükse hücrelerden taşacak
bence bir bakın ondan sonra üzerinde çalışalım
kodlar:

Sub resimekle()
Dim i As Integer
Dim j As Integer
Dim res As String
On Error Resume Next
For i = 1 To 601 Step 20
For j = 3 To 17 Step 7
res = "D:\resimler\" & Cells(i, j).Value & ".jpg"
Cells(i, j).Offset(1, 0).Select
ActiveSheet.Pictures.Insert res
Next j
Next i
MsgBox "resimler eklendi"
End Sub

 

[Korhan Ayhan]

Selamlar,

Alternatif olarak aşağıdaki kodu sayfanızın kod bölümüne uygulayıp denermisiniz.

Kod hücredeki "Model No" ya göre çalışmaktadır. Hata oluşmaması için koda eklemeler yaptım. Hücre zemin rengi kahverengi ise ve hücrenin solundaki hücrede "MODEL:" yazıyorsa kod çalışacaktır.

Option Explicit
 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Resim As OLEObject
    Dim Yeni_Resim As OLEObject
    Dim Adres As Range
    Dim Dosya_Yolu As String
    Dim Resim_Adı As String
    
    If Intersect(Target, [C:C,J:J,Q:Q]) Is Nothing Then Exit Sub
    If Target.Interior.ColorIndex <> 40 Or Target = "" Or Not IsNumeric(Target) Then Exit Sub
    If Target.Offset(0, -2) <> "MODEL:" Then Exit Sub
    
    Application.ScreenUpdating = False
    
    Dosya_Yolu = ThisWorkbook.Path & "\RESİMLER\"
    Resim_Adı = Target.Value & ".jpg"
    Set Adres = Range(Target.Offset(1, -2).Address, Target.Offset(14, 0).Address)
    
    If ActiveSheet.Shapes.Count > 0 Then
        For Each Resim In ActiveSheet.OLEObjects
            If Not Intersect(Range(Resim.TopLeftCell.Address & ":" & Resim.BottomRightCell.Address), Adres) Is Nothing Then
                Resim.Delete
            End If
        Next
    End If
    
    Set Yeni_Resim = ActiveSheet.OLEObjects.Add(ClassType:="Forms.Image.1", Link:=False, _
        DisplayAsIcon:=False, Left:=Adres.Left, Top:=Adres.Top, Width:=Adres.Width, Height:=Adres.Height)
    
    With Yeni_Resim
        .Top = Adres.Top
        .Left = Adres.Left
        .Height = Adres.Height
        .Width = Adres.Width
        .Object.PictureSizeMode = fmPictureSizeModeStretch
    End With
    
    If Dir(Dosya_Yolu & Resim_Adı) <> "" Then
        Yeni_Resim.Object.Picture = LoadPicture(Dosya_Yolu & Resim_Adı)
    Else
        Yeni_Resim.Object.Picture = LoadPicture(Dosya_Yolu & "Stok_Resmi_Yok.jpg")
    End If
    
    Application.ScreenUpdating = True
End Sub

 

[ethem.belen]

Üstat Allah razı olsun, supersin. Allah ne muradın varsa versin. Daha diyebilirimki gerçekten çok teşekkürler. Beni nasıl bir yükten kurtardınız bilemezsiniz.Sayılar...
EVOLER üstat sizede teşekkür ederim. Koray AYHAN Beyin hazırladığı tam sorumun cevabı,hatta fazlası var.İlginize tekrar teşekkür ederim

 

[Evolver]

eee daha onlardan öğrenecek çok şeyimiz var
hakkaten takdire şayan bir çalışma
ellerine sağlık uzmanım

 

[Evolver]

eğer korhan hocam ilgilenirse bu vesileyle kendisine birşey sormak istiyorum (intersect i anlamak adına)

a) If Intersect(Target, [C:C]) Is Nothing Then Exit Sub
ifadesi ile
b) If Target.Column <> 3 Then Exit Sub
ifadesi arasındaki fark nedir

 

[Korhan Ayhan]

Selamlar,

Sn. Evolver kısaca açıklamaya çalışayım;

Intersect (kesişmek) anlamına gelmektedir. Sizin yazmış olduğunuz iki kod arasında işleyiş açısından fark yoktur. İkiside "C" sütunu dışındaki hücrelerde işlem yapmadan işlemi sonlandır anlamına gelmektedir. Fakat koda başka sütunlarda eklenmek istenseydi. Bu durumda sizin yazdığınız ikinci koda başka "Target.Column" ifadeleri ekleyerek kontrol sağlamak gerekecekti. İşte burada "Intersect" komutu bize yazım kolaylığı sağlamaktadır.

 

[Evolver]

teşekkür ederim

 

[ethem.belen]

Üstad müsadenizle birşey sormak istiyorum. Bu dosyada ''resim sil'' gibi resim ekle butonuda konabilirmi?

 

[baydeniro]

Teşekkürler güzel bir çalışma