Soru Köprü oluşturulmuş resmi excele çekmek

Katılım
17 Aralık 2015
Mesajlar
17
Excel Vers. ve Dili
2016, Türkçe
Merhaba,

Köprü ile linklerini oluşturduğum resimleri excel çalışma sayfasına gömmek istiyorum. Çok fazla resim olduğu için tek tek yapmak haftalarımı alabilir. Bunun kolay bir yolu var mıdır? Makrosuz halletmeye çalışıyorum ama olmayacak sanırım. Örnek dosya
 
Katılım
12 Aralık 2015
Mesajlar
1,207
Excel Vers. ve Dili
Türkçe Ofis 2007
Resmi F sütununda köprünün bulunduğu hücre ile aynı satıra yapıştırıyor, ancak F sütunundaki hücrelerin boyutunu (en, boy, genişlik ve yükseklik) ayarlamanız gerekiyor.
Kod:
Sub Resim_Ekle()
Dim yol As String
For i = 2 To Cells(Cells.Rows.Count, 5).End(3).Row
yol = Range("E" & i).Hyperlinks(1).Address
With ActiveSheet.Pictures.Insert(yol)
.Left = Range("F" & i).Left 'Resmin görüleceği hücre Soldan
.Top = Range("F" & i).Top 'Resmin görüleceği hücre Üstten
.Width = Range("F" & i).Width
.Height = Range("F" & i).Height
.Name = Range("B" & i)
End With
Next
End Sub
 
Son düzenleme:
Katılım
17 Aralık 2015
Mesajlar
17
Excel Vers. ve Dili
2016, Türkçe
Resmi F sütununda köprünün bulunduğu hücre ile aynı satıra yapıştırıyor, ancak F sütunundaki hücrelerin boyutunu (en, boy, genişlik ve yükseklik) ayarlamanız gerekiyor.
Kod:
Sub Resim_Ekle()
Dim yol As String
For i = 2 To Cells(Cells.Rows.Count, 5).End(3).Row
yol = Range("E" & i).Hyperlinks(1).Address
With ActiveSheet.Pictures.Insert(yol)
.Left = Range("F" & i).Left 'Resmin görüleceği hücre Soldan
.Top = Range("F" & i).Top 'Resmin görüleceği hücre Üstten
.Width = Range("F" & i).Width
.Height = Range("F" & i).Height
.Name = Range("B" & i)
End With
Next
End Sub
Çok teşekkür ederim. Tam aklımdaki gibi çalışıyor. En kısa zamanda makro öğrenip bunun gibi basit sorularla sizleri rahatsız etmeyeceğim.
 
Katılım
12 Aralık 2015
Mesajlar
1,207
Excel Vers. ve Dili
Türkçe Ofis 2007
Makroyu biraz geliştirdim, Resme tıklayınca resmi büyütüyor, tekrar tıklayınca eski boyutuna getiriyor. Hücre boyutu ile bir ayarlama yapmanıza gerek kalmıyor.
Kod:
Sub Resim_Ekle()
Dim yol As String
For i = 2 To Cells(Cells.Rows.Count, 5).End(3).Row
yol = Range("E" & i).Hyperlinks(1).Address
With ActiveSheet.Pictures.Insert(yol)
.Left = Range("F" & i).Left 'Resmin görüleceği hücre Soldan
.Top = Range("F" & i).Top 'Resmin görüleceği hücre Üstten
.Height = Range("F" & i).Height
.Name = Range("B" & i)
.OnAction = "Resim_Büyüt"
End With
Next
End Sub
Sub Resim_Büyüt()
Dim ActiveShape As Shape
  ButtonName = Application.Caller
  Set ActiveShape = ActiveSheet.Shapes(ButtonName)
If ActiveSheet.Shapes(ActiveShape.Name).Width = 15 Then
ActiveSheet.Shapes(ActiveShape.Name).Width = 250
Else
ActiveSheet.Shapes(ActiveShape.Name).Width = 15
End If
End Sub
 
Katılım
17 Aralık 2015
Mesajlar
17
Excel Vers. ve Dili
2016, Türkçe
Makroyu biraz geliştirdim, Resme tıklayınca resmi büyütüyor, tekrar tıklayınca eski boyutuna getiriyor. Hücre boyutu ile bir ayarlama yapmanıza gerek kalmıyor.
Kod:
Sub Resim_Ekle()
Dim yol As String
For i = 2 To Cells(Cells.Rows.Count, 5).End(3).Row
yol = Range("E" & i).Hyperlinks(1).Address
With ActiveSheet.Pictures.Insert(yol)
.Left = Range("F" & i).Left 'Resmin görüleceği hücre Soldan
.Top = Range("F" & i).Top 'Resmin görüleceği hücre Üstten
.Height = Range("F" & i).Height
.Name = Range("B" & i)
.OnAction = "Resim_Büyüt"
End With
Next
End Sub
Sub Resim_Büyüt()
Dim ActiveShape As Shape
  ButtonName = Application.Caller
  Set ActiveShape = ActiveSheet.Shapes(ButtonName)
If ActiveSheet.Shapes(ActiveShape.Name).Width = 15 Then
ActiveSheet.Shapes(ActiveShape.Name).Width = 250
Else
ActiveSheet.Shapes(ActiveShape.Name).Width = 15
End If
End Sub
Type mismatch hatası veriyor.
 
Katılım
17 Aralık 2015
Mesajlar
17
Excel Vers. ve Dili
2016, Türkçe
Hepsinde veriyor. Bu arada bütün sayfalarda çalışan ilk kod bir sayfada çalışmadı ilginç bir şekilde. 400 yazan bir hata verdi, açıklamasız.
 
Katılım
17 Aralık 2015
Mesajlar
17
Excel Vers. ve Dili
2016, Türkçe
İlk makroda 400 hatası, diğerlerinde compile error hatası alıyorum. Herhangi bir noktada hata yapmıyorumdur umarım.
 
Katılım
17 Aralık 2015
Mesajlar
17
Excel Vers. ve Dili
2016, Türkçe
Estağfurullah.
Run-time error '1004':
Pictures sınıfının Insert özelliği alınamıyor. diye bir hata veriyor. With ActiveSheet.Pictures.Insert(yol) satırında
 
Katılım
12 Aralık 2015
Mesajlar
1,207
Excel Vers. ve Dili
Türkçe Ofis 2007
Biraz acele ettim E2 ve E3 deki köprü adresini değiştirmiştim.
Makronun başını aşağıdaki şekilde değiştirin
Sub Resim_Ekle()
On Error Resume Next
 
Katılım
17 Aralık 2015
Mesajlar
17
Excel Vers. ve Dili
2016, Türkçe
On Error Resume Next hata vermesi halinde sıradaki satıra geçiriyor sanırım. Hatayı "With ActiveSheet.Pictures.Insert(yol)" satırında aldığım için hiçbir işlem yapmıyor. Şikayetçi gibi görünmek istemiyorum ama; bir de tam olarak açıklamadığım için sanırım; resim dosyalarını kaynak dosyalara bağlı olacak şekilde yazmışsınız makroyu. Ben Excel dosyasına gömmek istiyordum. Yani excel dosyası taşındığında resim klasörüyle bağlantısı kalmasın istiyorum. Başınızı çok ağrıttım. Hakkınızı helal edin lütfen :)
 
Katılım
28 Ocak 2020
Mesajlar
4
Excel Vers. ve Dili
vba
Altın Üyelik Bitiş Tarihi
03-02-2021
bende de çalışmadı hocam linke basınca mı geliyor resim tam anlamadım kurguyu da
 
Katılım
12 Aralık 2015
Mesajlar
1,207
Excel Vers. ve Dili
Türkçe Ofis 2007
Resin_Ekle Makrosunu sadece bir defa çalıştıracaksınız, Resimler excele gömülecek. Sonra silebilirsiniz Makro E sütunundaki köprü adresleri doğru ise ve öyle bir resim dosyası varsa resimleri excel e ekliyor. Resimleri doğru şekilde aldıktan sonra F sütunu da silebilir siniz
Resim_Büyüt Makrosunu devamlı büyütmek küçültmek için kullanacaksınız.
 
Katılım
17 Aralık 2015
Mesajlar
17
Excel Vers. ve Dili
2016, Türkçe


Resimler gömülü hale gelmiyor maalesef. Dosyayı başka bir yere kopyaladığımda resimler gidiyor.
 
Katılım
12 Aralık 2015
Mesajlar
1,207
Excel Vers. ve Dili
Türkçe Ofis 2007
Versiyon farklılığından mı diye düşünüyorum.
#10 nolu mesajdaki dosyayı indirip, ilk açtığınızda F2 ve F3 hücrelerinde resim var mıydı?
 
Katılım
12 Aralık 2015
Mesajlar
1,207
Excel Vers. ve Dili
Türkçe Ofis 2007
Ben ofis 2007 ile çalışıyorum, şu an başka bilgisayardan denemem mümkün değil. Siz "makro kaydet" tıklayıp, manuel olarak bir resim ekledikten sonra "makro kaydet" durdurup bu makroyu mesaja ekleye bilirmisiniz.
 
Katılım
12 Aralık 2015
Mesajlar
1,207
Excel Vers. ve Dili
Türkçe Ofis 2007
Sn EmrExcel16 Sizin önerinize göre kodları yeniledim.
Sayın bulut99 F sütunundaki hücrelerin boyutunu istediğiniz gibi ayarlayın ve kodlarda 60 olarak ayarladığım resim genişliği siz kendinize göre değiştirin.
Kod:
Sub Resim_Ekle()
On Error Resume Next
Dim yol As String
For i = 2 To Cells(Cells.Rows.Count, 5).End(3).Row
yol = Range("E" & i).Hyperlinks(1).Address
 Set resim = ActiveSheet.Shapes.AddPicture(yol, True, True, Range("F" & i).Left, Range("F" & i).Top, 60, Range("F" & i).Height)
resim.OnAction = "Resim_Büyüt"
resim.Name = Range("B" & i)
Next
End Sub
Sub Resim_Büyüt()
Dim ActiveShape As Shape
  ButtonName = Application.Caller
  Set ActiveShape = ActiveSheet.Shapes(ButtonName)
If ActiveSheet.Shapes(ActiveShape.Name).Width = 60 Then
ActiveSheet.Shapes(ActiveShape.Name).Width = 60 * 3
ActiveSheet.Shapes(ActiveShape.Name).Height = Range("F2").Height * 3
Else
ActiveSheet.Shapes(ActiveShape.Name).Height = Range("F2").Height
ActiveSheet.Shapes(ActiveShape.Name).Width = 60
End If
End Sub
 
Üst