Diğer Sayfadan Resim Çekme (Resim Çağırma) Listesi

[ThaLees]

Merhabalar
Konu hakkında nette ve sitede bir çok konu ve cevap var. 2 gündür arıyorum. Benzer olan 1 adet bulabildim lakin onuda uyarlayamadım. Diğer bulduklarım genelde 1 hücreye yazılan veriye göre karşısındaki hücreye resim çağırma. Benim aradığım listeden resmi başka bir listeye çağırma. Klasörden değil ! Başka bir excel sayfasından.
Eğer şu sayfada istediğiniz var diyebilirseniz bu da benim için kafidir.

Ek : Resim Deneme.xlsx

Yapmak istediğimi örneklersem eğer ;

Ekteki örnekte 2 adet excel sayfası var.
Sayfa 1 = BİLGİ = Resimlerin gelmesini istediğim sayfa. Teklif (Proforma) Sayfamız
Sayfa 2 = RESİM = Resimlerin olduğu sayfa. Stok kodu, ürün resimleri ve ürün detayları olan excel sayfamız.

Teklif sayfasında bir satıra stok kodunu yazdığımda RESİM sayfasındaki o stok kodunun karşısındaki resimi getirsin.
Yukarıda koymuş olduğum örnekte benzer bir liste yaptım. Veri Doğrulaması olmak zorunluluğunda değil. RESİM sayfası yaklaşık 500-600 satırlık bir sayfa olacak. BİLGİ sayfası da 40-50 satırlık bir sayfa.

Buna göre
* Eğer bunu makro ile yapacaksak Resim boyutlandırma da gerekecek. Ayrıca stok kodu değiştiğinde önceki resimi de silmesi gerekecek.
* Eğer bunu makrosuz yapacaksak Resim boyutu önceki boyutunda mı olacak ? Resim silme işine tahminimce gerek kalmayacak çünkü resim eklemeyecek var olan resmi değiştirecek. ( Tercihimdir )

Şimdiden teşekkürler

 

[EmrExcel16]

Merhaba , her iki yöntem ile hazırlanmış dosyalar ektedir.

Makrosuz kullanılan da Ad tanımlaması yapılmıştır tek hücreye , her satır için çoğaltabilirsiniz.

Tavsiyem ve daha kullanışlı olarak gördüğüm makrolu olan çözüm dosyasıdır.

Makrosuz dosyada kullanılan ad tanımlama formülü

=DOLAYLI("RESİM!B"&KAÇINCI(BİLGİ!$A$2;RESİM!$A$2:$A$100;0)+1)

Kodlar

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("A2:A1000")) Is Nothing Then Exit Sub
    If Target.Count > 1 Then Exit Sub
    If Target <> "" Then
        Dim Resim, adress, ResimAdi
        On Error Resume Next
        For Each Resim In ActiveSheet.Shapes
            adress = Resim.TopLeftCell.Row
            If Target.Row = adress Then
                Resim.Delete
                Exit For
            End If
     
        Next
        For Each Resim In Sheets("Resim").Shapes
            adress = Resim.TopLeftCell.Column
            If adress = 2 Then
                ResimAdi = Sheets("Resim").Cells(Resim.TopLeftCell.Row, 1).Value
                If ResimAdi = Target Then
                    Resim.Copy
                    ActiveSheet.Paste Destination:=Cells(Target.Row, 2)
                    With Cells(Target.Row, 2)
                        Selection.ShapeRange.LockAspectRatio = msoFalse
                        Selection.Height = .MergeArea.Height - 4
                        Selection.Width = .MergeArea.Width - 4
                        Selection.Top = .Top + 2
                        Selection.Left = .Left + 2
                        Selection.Placement = xlMoveAndSize
                    End With
                    Target.Select
                    Exit Sub
                End If
            End If
        Next
    End If

End Sub

 

[ThaLees]

Merhaba , her iki yöntem ile hazırlanmış dosyalar ektedir.

Makrosuz kullanılan da Ad tanımlaması yapılmıştır tek hücreye , her satır için çoğaltabilirsiniz.

Tavsiyem ve daha kullanışlı olarak gördüğüm makrolu olan çözüm dosyasıdır.

Makrosuz dosyada kullanılan ad tanımlama formülü

=DOLAYLI("RESİM!B"&KAÇINCI(BİLGİ!$A$2;RESİM!$A$2:$A$100;0)+1)

Kodlar

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("A2:A1000")) Is Nothing Then Exit Sub
    If Target.Count > 1 Then Exit Sub
    If Target <> "" Then
        Dim Resim, adress, ResimAdi
        On Error Resume Next
        For Each Resim In ActiveSheet.Shapes
            adress = Resim.TopLeftCell.Row
            If Target.Row = adress Then
                Resim.Delete
                Exit For
            End If
     
        Next
        For Each Resim In Sheets("Resim").Shapes
            adress = Resim.TopLeftCell.Column
            If adress = 2 Then
                ResimAdi = Sheets("Resim").Cells(Resim.TopLeftCell.Row, 1).Value
                If ResimAdi = Target Then
                    Resim.Copy
                    ActiveSheet.Paste Destination:=Cells(Target.Row, 2)
                    With Cells(Target.Row, 2)
                        Selection.ShapeRange.LockAspectRatio = msoFalse
                        Selection.Height = .MergeArea.Height - 4
                        Selection.Width = .MergeArea.Width - 4
                        Selection.Top = .Top + 2
                        Selection.Left = .Left + 2
                        Selection.Placement = xlMoveAndSize
                    End With
                    Target.Select
                    Exit Sub
                End If
            End If
        Next
    End If

End Sub

Makrolu dosya
Makrosuz dosya

Teşekkürler.
Buradan kopyalaya kopyalaya excel öğrendim sayenizde.

 

[ThaLees]

Merhaba , her iki yöntem ile hazırlanmış dosyalar ektedir.

Makrosuz kullanılan da Ad tanımlaması yapılmıştır tek hücreye , her satır için çoğaltabilirsiniz.

Tavsiyem ve daha kullanışlı olarak gördüğüm makrolu olan çözüm dosyasıdır.

Makrosuz dosyada kullanılan ad tanımlama formülü

=DOLAYLI("RESİM!B"&KAÇINCI(BİLGİ!$A$2;RESİM!$A$2:$A$100;0)+1)

Kodlar

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("A2:A1000")) Is Nothing Then Exit Sub
    If Target.Count > 1 Then Exit Sub
    If Target <> "" Then
        Dim Resim, adress, ResimAdi
        On Error Resume Next
        For Each Resim In ActiveSheet.Shapes
            adress = Resim.TopLeftCell.Row
            If Target.Row = adress Then
                Resim.Delete
                Exit For
            End If
     
        Next
        For Each Resim In Sheets("Resim").Shapes
            adress = Resim.TopLeftCell.Column
            If adress = 2 Then
                ResimAdi = Sheets("Resim").Cells(Resim.TopLeftCell.Row, 1).Value
                If ResimAdi = Target Then
                    Resim.Copy
                    ActiveSheet.Paste Destination:=Cells(Target.Row, 2)
                    With Cells(Target.Row, 2)
                        Selection.ShapeRange.LockAspectRatio = msoFalse
                        Selection.Height = .MergeArea.Height - 4
                        Selection.Width = .MergeArea.Width - 4
                        Selection.Top = .Top + 2
                        Selection.Left = .Left + 2
                        Selection.Placement = xlMoveAndSize
                    End With
                    Target.Select
                    Exit Sub
                End If
            End If
        Next
    End If

End Sub

Makrolu dosya
Makrosuz dosya

Son olarak pekala bunun Resimlerin olduğu sayfanın yolunu nasıl değiştireceğim ? Aynı excelde de başka bir çalışma kitabının sayfasında ise ?

 

[EmrExcel16]

Sheets("Resim")

Resim yazan yer sayfa ismidir , istediğiniz gibi değiştirebilirsiniz.

 

[ThaLees]

Sheets("Resim")

Resim yazan yer sayfa ismidir , istediğiniz gibi değiştirebilirsiniz.

Onu anladımda mesela
C:\Users\Kullanıcı\Desktop\ konumunda "Resim Deneme" excel çalışma kitabındaki "Sayfa 1" Sheeti gibi ?

 

[EmrExcel16]

Verilen kodlar son isteğinize uygun değil, ilk isteğinize uygun olarak yazıldı, eğer bu şekilde de bir isteğiniz varsa kodların revize edilmesi gerekli.

 

[ThaLees]

Verilen kodlar son isteğinize uygun değil, ilk isteğinize uygun olarak yazıldı, eğer bu şekilde de bir isteğiniz varsa kodların revize edilmesi gerekli.

İlk başta belirttiğim şekilde olursa gerisini revize edebilirim diye düşünmüştüm ama maalesef beceremedim. Klasörden alabiliyorum resimleri. ama başka bir excel sayfasının içinden almam gereken yerde tıkanıyorum. O şekilde revize etmeniz mümkün müdür acaba ?

 

[EmrExcel16]

Bu şekilde revize ettim kodları.

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("A2:A1000")) Is Nothing Then Exit Sub
    If Target.Count > 1 Then Exit Sub
    If Target <> "" Then
        Dim Resim, adress, ResimAdi, Sayfa, Dosya, Yol
        Application.ScreenUpdating = False
        Application.DisplayAlerts = False
        On Error Resume Next
        
        '''''''''''''''''''''''''' Tanimlamalari kendinize göre uyarlayin
        Sayfa = "Resim"
        Dosya = "Resimler.xlsm"
        Yol = "C:\Desktop\"
        '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        
        Workbooks.Open Filename:=Yol & Dosya
        ThisWorkbook.Activate
        For Each Resim In ActiveSheet.Shapes
            adress = Resim.TopLeftCell.Row
            If Target.Row = adress Then
                Resim.Delete
                Exit For
            End If
        Next
        For Each Resim In Workbooks(Dosya).Sheets(Sayfa).Shapes
            adress = Resim.TopLeftCell.Column
            If adress = 2 Then
                ResimAdi = Workbooks(Dosya).Sheets(Sayfa).Cells(Resim.TopLeftCell.Row, 1).Value
                If ResimAdi = Target Then
                    Resim.Copy
                    ActiveSheet.Paste Destination:=Cells(Target.Row, 2)
                    With Cells(Target.Row, 2)
                        Selection.ShapeRange.LockAspectRatio = msoFalse
                        Selection.Height = .MergeArea.Height - 4
                        Selection.Width = .MergeArea.Width - 4
                        Selection.Top = .Top + 2
                        Selection.Left = .Left + 2
                        Selection.Placement = xlMoveAndSize
                    End With
                    Target.Select
                    GoTo git
                End If
            End If
        Next
git:
        Workbooks(Dosya).Close
        Application.DisplayAlerts = True
        Application.ScreenUpdating = True
    End If
End Sub

 

[ThaLees]

Bu şekilde revize ettim kodları.

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("B2:B1000")) Is Nothing Then Exit Sub
    If Target.Count > 1 Then Exit Sub
    If Target <> "" Then
        Dim Resim, adress, ResimAdi, Sayfa, Dosya, Yol
        Application.ScreenUpdating = False
        Application.DisplayAlerts = False
        On Error Resume Next
        
        '''''''''''''''''''''''''' Tanimlamalari kendinize göre uyarlayin
        '''\\BA-374514\ihracat\TASLAKLAR\[FİYAT LİSTESİ.xlsx]FİYAT LISTESI
        Sayfa = "FİYAT LISTESI"
        Dosya = "[FİYAT LİSTESİ.xlsx]"
        Yol = "\\BA-374514\ihracat\TASLAKLAR\"
        '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        
        Workbooks.Open Filename:=Yol & Dosya
        ThisWorkbook.Activate
        For Each Resim In ActiveSheet.Shapes
            adress = Resim.TopLeftCell.Row
            If Target.Row = adress Then
                Resim.Delete
                Exit For
            End If
        Next
        For Each Resim In Workbooks(Dosya).Sheets(Sayfa).Shapes
            adress = Resim.TopLeftCell.Column
            If adress = 2 Then
                ResimAdi = Workbooks(Dosya).Sheets(Sayfa).Cells(Resim.TopLeftCell.Row, 1).Value
                If ResimAdi = Target Then
                    Resim.Copy
                    ActiveSheet.Paste Destination:=Cells(Target.Row, 6)
                    With Cells(Target.Row, 6)
                        Selection.ShapeRange.LockAspectRatio = msoFalse
                        Selection.Height = .MergeArea.Height - 4
                        Selection.Width = .MergeArea.Width - 4
                        Selection.Top = .Top + 2
                        Selection.Left = .Left + 2
                        Selection.Placement = xlMoveAndSize
                    End With
                    Target.Select
                    GoTo git
                End If
            End If
        Next
git:
        Workbooks(Dosya).Close
        Application.DisplayAlerts = True
        Application.ScreenUpdating = True
    End If
End Sub

Maalesef çalışmadı bu şekilde Revize halini de yukarıda koydum. KOntrol edermisiniz lütfen.

Stok kodları Resmin geleceği excelde B stununda resmin olduğu excelde A stununda
Resim; Resimlerin olduğu excelde B stunundan Diğer excelin G stununa gelecek.
Adres : \\BA-374514\ihracat\TASLAKLAR\[FİYAT LİSTESİ.xlsx]FİYAT LISTESI


Birşeyi ya yanlış yaptım ya atladım ama neyi bulamıyorum. Adresmi yanlış diye düşündüm aynı adrese klasör koyup bu adresler klasörden resim alabildim.

 

[EmrExcel16]

On Error Resume Next şu satırı silip hata verdiği satırı bildirebilir misiniz ?

Dosya isimlerinde [ ] şu işaretleri kaldırın , bunlar formüller ile çalışırken oluşur.

Bu dosyadan bağımsız olarak dosyayı Workbooks.Open metoduyla dosyayı açabiliyor musunuz ona da bakın.

 

[tamermeral]

Merhabalar,
Dosyadan çağırdığımız resmi "birleştirilmiş hücreye" örneğin A2-B2 birleştirilmiş hücresine getirmek için kodda hangi değişikliği yapmamız gerekiyor? Böyle birşey mümkün mü?
Yardımlarınızı rica ederim.

Teşekkürler.

 

[ThaLees]

Merhabalar,
Dosyadan çağırdığımız resmi "birleştirilmiş hücreye" örneğin A2-B2 birleştirilmiş hücresine getirmek için kodda hangi değişikliği yapmamız gerekiyor? Böyle birşey mümkün mü?
Yardımlarınızı rica ederim.

Teşekkürler.

Merhabalar
Diğerlerini hallettiyseniz hücrenin birleştirilmiş olmasının pek öneminin olduğunu düşünmüyorum. Sonuçta hücre adına göre gidiyor. Ben yapamadığımdan bütün resinleri jpeg olarak kaydedio klasörden çağırmayı seçtim.

 

[halit3]

Merhabalar,
Dosyadan çağırdığımız resmi "birleştirilmiş hücreye" örneğin A2-B2 birleştirilmiş hücresine getirmek için kodda hangi değişikliği yapmamız gerekiyor? Böyle birşey mümkün mü?
Yardımlarınızı rica ederim.

Teşekkürler.

With Cells(Target.Row, 6)

yukarıdaki bölüm yerine
Bu
With Range("A2:B2")
veya
With Range(Cells(2, "a"), Cells(2, "b"))
bu

 

[tamermeral]

With Cells(Target.Row, 6)

yukarıdaki bölüm yerine
Bu
With Range("A2:B2")
veya
With Range(Cells(2, "a"), Cells(2, "b"))
bu

Çok teşekkür ederim, emeğinize sağlık. işimi gördü.

 

[tamermeral]

Aynı resmi iki farklı hücreye getirmek istesek olabilirmi peki? yani hem ("A2:B2") hemde ("C22") hücrelerine aynı resim gelebilir mi?

Teşekkürler.

 

[halit3]

kodu yazan kişinin düzeltmesi daha doğrusu olur

bu bölümü çoğaltman lazım.

ActiveSheet.Paste Destination:=Cells(Target.Row, 6)
                    With Cells(Target.Row, 6)
                        Selection.ShapeRange.LockAspectRatio = msoFalse
                        Selection.Height = .MergeArea.Height - 4
                        Selection.Width = .MergeArea.Width - 4
                        Selection.Top = .Top + 2
                        Selection.Left = .Left + 2
                        Selection.Placement = xlMoveAndSize
                    End With

ActiveSheet.Paste Destination:=Cells(Target.Row, 6)
With Range(Cells(2, "a"), Cells(2, "b"))
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.Height = .MergeArea.Height - 4
Selection.Width = .MergeArea.Width - 4
Selection.Top = .Top + 2
Selection.Left = .Left + 2
Selection.Placement = xlMoveAndSize
End With

ActiveSheet.Paste Destination:=Cells(Target.Row, 6)
With Range(Cells(2, "c"), Cells(2, "d"))
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.Height = .MergeArea.Height - 4
Selection.Width = .MergeArea.Width - 4
Selection.Top = .Top + 2
Selection.Left = .Left + 2
Selection.Placement = xlMoveAndSize
End With

 

[tamermeral]

Merhabalar,
Dosyadan resim ekleme işlemi tamam, fakat resim eklediğimiz dosyayı mail yolu ile gönderince diğer tarafta resimler gözükmüyor. excel sayfasının resimler gözükecek şekilde gönderiminin yolu varmıdır? (Dosyadaki resimlerle birlikte sıkıştırıp göndermek istemiyorum.)

Teşekkürler.

 

[ThaLees]

Merhaba , her iki yöntem ile hazırlanmış dosyalar ektedir.

Makrosuz kullanılan da Ad tanımlaması yapılmıştır tek hücreye , her satır için çoğaltabilirsiniz.

Tavsiyem ve daha kullanışlı olarak gördüğüm makrolu olan çözüm dosyasıdır.

Makrosuz dosyada kullanılan ad tanımlama formülü

=DOLAYLI("RESİM!B"&KAÇINCI(BİLGİ!$A$2;RESİM!$A$2:$A$100;0)+1)

Kodlar

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("A2:A1000")) Is Nothing Then Exit Sub
    If Target.Count > 1 Then Exit Sub
    If Target <> "" Then
        Dim Resim, adress, ResimAdi
        On Error Resume Next
        For Each Resim In ActiveSheet.Shapes
            adress = Resim.TopLeftCell.Row
            If Target.Row = adress Then
                Resim.Delete
                Exit For
            End If
    
        Next
        For Each Resim In Sheets("Resim").Shapes
            adress = Resim.TopLeftCell.Column
            If adress = 2 Then
                ResimAdi = Sheets("Resim").Cells(Resim.TopLeftCell.Row, 1).Value
                If ResimAdi = Target Then
                    Resim.Copy
                    ActiveSheet.Paste Destination:=Cells(Target.Row, 2)
                    With Cells(Target.Row, 2)
                        Selection.ShapeRange.LockAspectRatio = msoFalse
                        Selection.Height = .MergeArea.Height - 4
                        Selection.Width = .MergeArea.Width - 4
                        Selection.Top = .Top + 2
                        Selection.Left = .Left + 2
                        Selection.Placement = xlMoveAndSize
                    End With
                    Target.Select
                    Exit Sub
                End If
            End If
        Next
    End If

End Sub

Merhabalar Tekrar O zaman çözemediğim konu tekrar tekrar önüme geliyor maalesef.
İnternette farklı yöntemler buldum ama hiç birini kullanamadım
* Makrosuz olarak yapmaya çalıştığımda Resime ad tanımlar iken "Başvuru Geçerli Değil" uyarısı arıyorum.
*Makrolu olarak başka excellerde kullandığım resim çağırma formülleri mevcut. Ama bu formatta olması gereken şu şekilde
"COLORS" sayfasındaki renkleri solundaki kodlarına göre "MATRIX" sayfasında bu kodu yazdığım hücrenin bir üst satırına resmin gelmesi.
Matris çok uzayıp gittiği için ya bu makro "MATRIX" sayfasının herhangi bir yerinede yazsan bir üstüne o koda ait resim gelecek şekilde olacak yada makrosuz yol ile çözüp veri doğrulama olan hücreyi her yere kopyalıcaz diye düşünüyorum.

Birde bu resimler mükerrer olarak birden fazla kez defalarca kullanılacağı için çalışma kitabının boyutu artacak. Dolayısıyla ilerde dosyayı kullanabilmek adına kasmayacak bir yöntem bulmam gerekiyor.

Şİmdiden teşekkürler

 

[ThaLees]

Merhabalar Tekrar O zaman çözemediğim konu tekrar tekrar önüme geliyor maalesef.
İnternette farklı yöntemler buldum ama hiç birini kullanamadım
* Makrosuz olarak yapmaya çalıştığımda Resime ad tanımlar iken "Başvuru Geçerli Değil" uyarısı arıyorum.
*Makrolu olarak başka excellerde kullandığım resim çağırma formülleri mevcut. Ama bu formatta olması gereken şu şekilde
"COLORS" sayfasındaki renkleri solundaki kodlarına göre "MATRIX" sayfasında bu kodu yazdığım hücrenin bir üst satırına resmin gelmesi.
Matris çok uzayıp gittiği için ya bu makro "MATRIX" sayfasının herhangi bir yerinede yazsan bir üstüne o koda ait resim gelecek şekilde olacak yada makrosuz yol ile çözüp veri doğrulama olan hücreyi her yere kopyalıcaz diye düşünüyorum.

Birde bu resimler mükerrer olarak birden fazla kez defalarca kullanılacağı için çalışma kitabının boyutu artacak. Dolayısıyla ilerde dosyayı kullanabilmek adına kasmayacak bir yöntem bulmam gerekiyor.

Şİmdiden teşekkürler

Merhabalar
Yardımcı olabilecek var mıdır acaba ?