Kod yardım.Resim

[kocaeliartvin]

Sub resimekle()
i = 5
For i = 1 To 10
Cells(i, 5).Select
ActiveSheet.Pictures.Insert ("E:\Malzeme Resim\Küçük Resim\ak 1820.jpg")
i = i + 1
Next
End Sub

Yukarıda ki kodlar ile ecxel 2007 de çalışma sayfasına resim yapıştırıyorum. Yanlız resimler hep aynı noktaya yapışıyor. Seçtiğim hücreye yapışması nasıl sağlanabilir.

Yardımcı olanlara şimdiden teşekkürler

 

[Huseyinkis]

Sub resimekle()
i = 5
For i = 1 To 10
Cells(i, 5).Select
ActiveSheet.Pictures.Insert ("E:\Malzeme Resim\Küçük Resim\ak 1820.jpg")
i = i + 1
Next
End Sub

Yukarıda ki kodlar ile ecxel 2007 de çalışma sayfasına resim yapıştırıyorum. Yanlız resimler hep aynı noktaya yapışıyor. Seçtiğim hücreye yapışması nasıl sağlanabilir.

Yardımcı olanlara şimdiden teşekkürler

For i = 1 To 10
Cells(i, 5).Select
ActiveSheet.Pictures.Insert ("E:\Malzeme Resim\Küçük Resim\ak 1820.jpg")
Next
End Sub


bu şekilde deneyin

 

[kocaeliartvin]

İlginiz için teşekkür ederim. Yine tek bir nokta üzerinde üst üste yapıştırdı resimleri Seçili olan hücrelere yapıştırmadı

 

[Huseyinkis]

İlginiz için teşekkür ederim. Yine tek bir nokta üzerinde üst üste yapıştırdı resimleri Seçili olan hücrelere yapıştırmadı

Ozaman Birde Boyle Deniyelim.

Sub Tıkla()
Dim sPicture As String, pic As Picture
For i = 1 To 10
Cells(i, 5).Select
sPicture = ("E:\Malzeme Resim\Küçük Resim\ak 1820.jpg")
If sPicture = "False" Then Exit Sub
Set pic = ActiveSheet.Pictures.Insert(sPicture)
With pic
.ShapeRange.LockAspectRatio = msoFalse
.Height = ActiveCell.Height
.Width = ActiveCell.Width
.Top = ActiveCell.Top
.Left = ActiveCell.Left
.Placement = xlMoveAndSize
End With
Set pic = Nothing
Next
End Sub

 

[kocaeliartvin]

Hocam ellerinize sağlık. Verdiğiniz koddan yola çıkarak biraz geliştirme yaptım. istediğim şey her malın kendi resmini yapıştırması. Bu durumda resim isimleri değişiyor. Onu yaptım ve çalıştı ama bu kez üçüncü döngü de Hata 400 diye bi hata verdi.

Kod aşağıda ki gibidir. İstediğim şey malın kodu AB1 hücresine yazılı. AB1 hücresinde yazan değer aynı zamanda yükleyeceği resmin adı oluyor. Sırayla aşağı doğru her malın hizasında o malın resmi gelecek şekilde listelesin. Eğer o malın resmi klasörde yoksa da aynı adreste ki none.jpg dosyasını yapıştırsın.

tekrar teşekkür ederim


Sub Tıkla()
Dim sPicture As String, pic As Picture
For i = 1 To 10
Cells(i, 2).Select
Selection.Copy
[ab1].Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Cells(i, 5).Select
sPicture = ("e:\Malzeme Resim\Küçük Resim\" & [ab1] & ".jpg")
If sPicture = "False" Then Exit Sub
Set pic = ActiveSheet.Pictures.Insert(sPicture)
With pic
.ShapeRange.LockAspectRatio = msoFalse
.Height = ActiveCell.Height
.Width = ActiveCell.Width
.Top = ActiveCell.Top
.Left = ActiveCell.Left
.Placement = xlMoveAndSize
End With
Set pic = Nothing
Next
End Sub

 

[Huseyinkis]

Hocam ellerinize sağlık. Verdiğiniz koddan yola çıkarak biraz geliştirme yaptım. istediğim şey her malın kendi resmini yapıştırması. Bu durumda resim isimleri değişiyor. Onu yaptım ve çalıştı ama bu kez üçüncü döngü de Hata 400 diye bi hata verdi.

Kod aşağıda ki gibidir. İstediğim şey malın kodu AB1 hücresine yazılı. AB1 hücresinde yazan değer aynı zamanda yükleyeceği resmin adı oluyor. Sırayla aşağı doğru her malın hizasında o malın resmi gelecek şekilde listelesin. Eğer o malın resmi klasörde yoksa da aynı adreste ki none.jpg dosyasını yapıştırsın.

tekrar teşekkür ederim

End Sub

aşağıdaki kodu kullanarak resimleri ekleyebilirsiniz. resim linklerini

Sub Tıkla()
Dim sPicture As String, pic As Picture
For i = 1 To 10                                              '10 tane stok kartı resmini bul
Cells(i, 5).Select                                           'resimleri E1 - E10 yapıştır
aaa = Range("E" & i).Value                                   'Resim isimleri E1 - E10 yazıyo
sPicture = ("e:\Malzeme Resim\Küçük Resim\" & aaa & ".jpg")  ' resmi tanımla
On Error GoTo atla3:                                       
GoTo atla2:                                                  
atla3:
sPicture = ("e:\Malzeme Resim\Küçük Resim\none.jpg")         'resim olmayınca tanımlanıcak resim
atla2:
Set pic = ActiveSheet.Pictures.Insert(sPicture)              
With pic                                                     
.ShapeRange.LockAspectRatio = msoFalse
.Height = ActiveCell.Height
.Width = ActiveCell.Width
.Top = ActiveCell.Top
.Left = ActiveCell.Left
.Placement = xlMoveAndSize
End With
Set pic = Nothing
Next                                                         
End Sub

 

[kocaeliartvin]

Kodlar bu haliyle Hata veriyor. 400 kodlu hata çıkıyor. Neyden kaynaklı olabilir