Klasörden Resim Ekleme

[ala15001400]

Merhabalar,

Makrolarla uğraşmayalı uzun zaman oldu. Acilen bir çalışmaya ihtiyaç duydum. Yardımcı olursanız çok memnun kalacağım. Bu arada forumda benzer konular buldum ama çalıştırınca hata verdi.

Çalışma Şu şekilde;
İçerisinde pek çok ürün fotosunun olduğu bir klasörüm var. Bu klasörde aynı zamanda bir excel dosyası var. Excel dosyasında A sütununda yer alan ürünlerin yanına B sütünunda resmini klasötden bulup ekleyecek bir makro. Makro A sütunu için tüm kodları klasöründe taradıktan sonra duracak. Eğer ürünün kodu var ama fotosu yoksa B sütununda resim alanına bir şey eklemeyecek. Biliyorum basit ama yardımcı olursanız sevinirim.
teşekkür ederim.

 

[muygun]

Merhaba;
Başlığınızdaki gereksiz "Basit ama unutmuşum" ibaresini kaldırırsanız iyi olur.
Konuyu neden "Basitleştirdiniz" anlamadım.
Excelin standartlarında olmayan ve vba ile çözüm üretilen her konu spesifiktir.
Eki deneyin.
İyi çalışmalar.

 

[ala15001400]

Merhabalar hocam. Çalışma için teşekkür ederim. Resmi, bulunduğu B sütunundaki hücre içerisine sığacak şekilde ayarlamanın bir yolu var mı?
Birde bu çalışmayı benim asıl çalışma kitabıma aktarmam gerekecek. Makroları görüntüle deyince benim bilgisayarda herhangi bir makro çıkmamaktadır. Bu neden kaynaklanmaktadır.

 

[muygun]

Hücrenin boyutlarına göre resim zaten ölçülendiriliyor.
Makro güvenliğini düşük önerilmez konumuna getirin.

 

[ala15001400]

Bende bu dediğiniz ölçülendirme olmadı. Ekran alıntısı ekledim. Diğer tarfatan, Excel Güven merkezinde Makro güvenliğini ilişikteki gibi çok düşürmüştüm, zaten. Excel 2010 kullanıyorum. Hazırladığınız makro çalışıyor ama makroları görüntüle dediğimde herhangi bir makronun gözükmemesinin başka nedeni olabilir mi ?

 

[muygun]

Ofis Programınız Lisanslı değilse kısıtlı yüklenmiş olabilir.
Başka bir pc de (eğer varsa Ofis 2003 yüklü) deneyin.
Gerekirse ofisi kaldırıp tekrar kurun.

 

[ala15001400]

Tamam. Teşekkür ederim.

 

[ala15001400]

Başka bilgisayarda denedim yine olmadı. Mümkünse makronun içeriğini buradan iletebilir misiniz ? Teşekkür ederim.

 

[muygun]

Sayfanın kod bölümüne;

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 1 Then
Application.ScreenUpdating = False
On Error Resume Next

Dim resim As Object, i As Long, yol As String, dosya As String
Sheets("PRODUCT").Select
yol = ThisWorkbook.Path & "\"
Set Alan = Range("b2:b655367")
For Each resimm In ActiveSheet.Pictures
If Not Intersect(resimm.TopLeftCell, Alan) Is Nothing Then
resimm.Delete
End If
Next
Set Alan = Nothing

For i = 2 To Cells(65536, "a").End(xlUp).Row
If Dir(yol & "\" & Cells(i, "a").Value & ".jpg") <> "" Then
dosya = "\" & Cells(i, "a").Value & ".jpg"
If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
Set P = ActiveSheet.Pictures.Insert(yol & dosya)

With Cells(i, "b")
t = .Top
l = .Left
w = .Offset(50, .Columns.Count).Left - .Left
h = .Offset(.Rows.Count, 50).Top - .Top
End With

With P
.Top = t + 1
.Left = l + 1
.Width = w - 1
.Height = h - 1
End With
Set P = Nothing
End If
Next i
Application.ScreenUpdating = True
End If
End Sub

İyi çalışmalar.

 

[ala15001400]

Teşekkür ederim. bu şekilde çözdüm.