Parça Listesinin Yanına Toplu Resim Getirmek.

Merhaba,

Bu makronun detayını anlatmak gerekirse, elinizde yüzlerce parça kodu var, ve bu kodların herbirinin tek tek resmini yanındaki hücreye getirmeye çalışıyorsunuz.İşte bu makro tam sizin aradığınız şey. Kodların olduğu ilgili sütunu seçin, resimleri hangi sütuna gelecek belirtin kodların birine F2 enter yapın.(Çünkü makro hücre verisi değiştikçe çalışıyor.) Tüm kodların karşısına resimleri getirecektir.Kod fazlalığına göre 1 dk'ya yakın bekleyebilirsiniz.

Umarım işinize yaraycaktır.

iyi günlerde kullanın.

Önemli;
Makromuzu ilgili sayfanın olduğu kod bölümüne koymanız gerekmektedir.

Public Function DosyaVarmi(dosyayolu As String) As Boolean On Error GoTo Çıkış If Not Dir(dosyayolu, vbDirectory) = vbNullString Then DosyaVarmi = True Çıkış: On Error GoTo 0 End Function 'worksheette bir değişiklik oldugunda bu kısım çalışıyor Private Sub Worksheet_Change(ByVal Target As Range) 'değişiklik b sutunundamı olmuş diye kontrol et, değilse direk olarak fonksiyondan çık If Intersect(Target, [E:E]) Is Nothing Then Exit Sub 'herhangi bir hata oluşursa Çıkış labelına git On Error GoTo Çıkış: ' ilk olarak yüklü olan Resimleri silelim ActiveSheet.DrawingObjects.Delete Dim ResimDosyaYolu As String Dim Resim As Object 'E deki 3 ile 255 arasındaki satırları kontrol edip resim ataması yapıyoruz, siz burayı isteğinize göre artırabilirsiniz For i = 3 To 255 'aktif sayfanın path bilgisini alıp, seçilen ürün idyi sonuna ekliyoruz ve dosyayı alıyoruz ResimDosyaYolu = "\\file_server\FOTO_METOD\Parca\" & "\" & Range("E" & i) & ".jpg" 'dosya yok ise hataya düşmemek için aşağıdaki kontrolü yapıyoruz. If DosyaVarmi(ResimDosyaYolu) Then ResimDosyaYolu = "\\file_server\FOTO_METOD\Parca\" & "\" & Range("E" & i) & ".jpg" Else ResimDosyaYolu = "\\file_server\FOTO_METOD\Parca\" & "\hata.jpg" End If 'resmi oluşturuyoruz. Set Resim = ActiveSheet.Pictures.Insert(ResimDosyaYolu) 'Resmi boyutlandırıyoruz With Range("f" & i) Resim.Top = .Top Resim.Left = .Left Resim.Height = 40 'Buradaki 2 ölçüyü istediğiniz ebatlarda ayarlayabilirsiniz. Resim.Width = 40 End With Next i Çıkış: End Sub