• FORUMU MOBİL UYGULAMADAN TAKİP EDİN

    Forumu isteyen üyelerimiz Tapatalk (Harici bir hizmet) üzerinden mobil uygulamadan takip edebilirler.
    iOS için : https://itunes.apple.com/app/id307880732?mt=8
    Android için : https://play.google.com/store/apps/details?id=com.quoord.tapatalkpro.activity
    adreslerinden indirebilirsiniz.

    Bir iki haftaya da foruma özel kendi uygulamamız yayında olacak.
ALTIN ÜYELİK Hakkında Bilgi
-----------------------

Klasörden Resim Çağırma

mcetinkaya65

Altın Üye
Altın Üye
Katılım
1 Mart 2011
Mesajlar
410
Beğeniler
0
Excel Vers. ve Dili
2016 türkçe
#1
Hazırladığım Programda Resimler klasörden excel üzerindeki form sayfasında E6 hücresinde yazan ismin resmini birleştirilmiş olan T6 hücresine getirmemiz mümkün mü?Form Sayfasındaki veriler indisle Veriler sayfasından çağırıyoruz.

Saygılarımla..
 

Ekli dosyalar

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
11,150
Beğeniler
209
Excel Vers. ve Dili
2003 excel türkçe
#2
Bu kodu bir modülün içine kopyala ve açılan liste kutusuna mause ile sağ tıkla makro ata seçeneğinden Resimlerekle2 seç ve kodu çalıştır.

Kod:

Kod:
Sub Resimlerekle2()

Dim s1
Set s1 = Sheets(ActiveSheet.Name)
Set Adres = s1.Range(s1.Cells(6, "t"), s1.Cells(10, "x"))
Dim Picture As Object
For Each Picture In s1.Shapes
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then
Set yer = s1.Range(s1.Cells(Picture.TopLeftCell.Row, Picture.TopLeftCell.Column), s1.Cells(Picture.BottomRightCell.Row, Picture.BottomRightCell.Column))

If yer.Address = Adres.Address Then

Picture.Delete
Exit For
End If

End If
Next Picture

ReDim uzanti(11)
uzanti(1) = "bmp":        uzanti(2) = "jpg"
uzanti(3) = "gif":        uzanti(4) = "pcx"
uzanti(5) = "tga":        uzanti(6) = "emf"
uzanti(7) = "abm":        uzanti(7) = "avi"
uzanti(8) = "png":        uzanti(9) = "jpeg"
uzanti(10) = "wmf":       uzanti(11) = "TIFF"

For j = 1 To 11
Dosya2 = ThisWorkbook.Path & "\Resimler\" & s1.Cells(6, "e") & "." & uzanti(Val(j))
If CreateObject("Scripting.FileSystemObject").FileExists(Dosya2) = True Then
Dosya = Dosya2
Exit For
End If
Next

If CreateObject("Scripting.FileSystemObject").FileExists(Dosya2) = True Then
Dosya = Dosya2
Else
Dosya = ThisWorkbook.Path & "\Resimler\ResimYok.jpg"
End If

If CreateObject("Scripting.FileSystemObject").FileExists(Dosya) = True Then
ad = s1.Pictures.Insert(Dosya).Name
s1.Shapes(ad).OLEFormat.Object.ShapeRange.LockAspectRatio = msoFalse
s1.Shapes(ad).OLEFormat.Object.Top = Adres.Top + 1
s1.Shapes(ad).OLEFormat.Object.Left = Adres.Left + 1
s1.Shapes(ad).OLEFormat.Object.ShapeRange.Height = Adres.Height - 2
s1.Shapes(ad).OLEFormat.Object.ShapeRange.Width = Adres.Width - 2

End If

End Sub
 

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
11,150
Beğeniler
209
Excel Vers. ve Dili
2003 excel türkçe
#4
Teşekkürler iyi çalışmalar
 

mcetinkaya65

Altın Üye
Altın Üye
Katılım
1 Mart 2011
Mesajlar
410
Beğeniler
0
Excel Vers. ve Dili
2016 türkçe
#5
Selmün aleyküm.
Halit3 ün makrosuyla yukardaki sorunu çözdük Allah Razı olsun. İnsan olarak gözümüz doymuyor. Form sayfasına makrolu öyle bir büton ekleyelim ki yazdır dediğimzde veriler sayfasından verileri form sayfasına resimle beraber çekip veriler sayfasının B stunundaki isimlere form dolurması mümkün mü. (toplu yazdır butonu)
Saygılarımla
 

Ekli dosyalar

Katılım
18 Ocak 2008
Mesajlar
11,150
Beğeniler
209
Excel Vers. ve Dili
2003 excel türkçe
#6
Aleyküm Selam
Kod

Kod:
Sub yazdır()

Worksheets("Form").Cells(1, 1).Value = 0
For i = 4 To Worksheets("Veriler").Cells(Rows.Count, "b").End(3).Row
Worksheets("Form").Cells(1, 1).Value = Worksheets("Form").Cells(1, 1).Value + 1

Call Resimlerekle2

Worksheets("Form").PageSetup.PrintArea = "$B$1:$X55"
Worksheets("Form").PrintOut Copies:=1, Collate:=True
Next i
MsgBox "işlem tamam"
End Sub
 
Üst