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

B

bulut99

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
 
A

alicimri

Katılım
12 Aralık 2015
Mesajlar
1,200
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:
B

bulut99

Katılım
17 Aralık 2015
Mesajlar
17
Excel Vers. ve Dili
2016, Türkçe
alicimri' Alıntı:
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
Genişletmek için tıkla ...
Ç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.
 
A

alicimri

Katılım
12 Aralık 2015
Mesajlar
1,200
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
 
B

bulut99

Katılım
17 Aralık 2015
Mesajlar
17
Excel Vers. ve Dili
2016, Türkçe
alicimri' Alıntı:
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
Genişletmek için tıkla ...
Type mismatch hatası veriyor.
 
B

bulut99

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.
 
B

bulut99

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.
 
B

bulut99

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
 
A

alicimri

Katılım
12 Aralık 2015
Mesajlar
1,200
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
 
B

bulut99

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 :)
 
A

aspire343434

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
 
A

alicimri

Katılım
12 Aralık 2015
Mesajlar
1,200
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.
 
B

bulut99

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.
 
A

alicimri

Katılım
12 Aralık 2015
Mesajlar
1,200
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ı?
 
A

alicimri

Katılım
12 Aralık 2015
Mesajlar
1,200
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.
 
A

alicimri

Katılım
12 Aralık 2015
Mesajlar
1,200
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
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst