• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

excel liste-jpeg eşleştirme yardım

S

simonadebisi

Katılım
7 Mart 2014
Mesajlar
20
Excel Vers. ve Dili
excel 2010
merhabalar,
öncelikle tüm excel.web.tr ailesine çok teşekkür ederim. Gerçekten excel hususunda birçok eksiğimi sayenizde giderdim.
Konuya gelecek olursak ;
bir excel dosyası düşünün. yaklaşık 10.000 personel ismi sicil numarası olan bir liste var. bir de o personellerin fotoğraflarının olduğu jpeg formatlı fotoğraf klasörü var. fotoğrafların isimleri personellerin sicil numarasına göre kaydedilmiş.
sorum ise şu,
excel listesinde yer alan personellerin karşı hücresine, sicil numarasına göre arama yaparak karşı hücresine ilgili personelin fotoğrafının çekilmesi.
böyle birşey mümkün mü ?
mümkün ise gerçekten çok büyük zaman tasarrufu sağlayacak.
yardımlarınızı bekliyorum,
teşekkürler şimdiden.
 

Ekli dosyalar

Son düzenleme:
Örnek dosya ekleyin ki, yardım alın.
 
dosya eklenmiştir.
yardımlarınızı bekliyorum.
şimdiden teşekkürler.
 
Ekte...

Kod: 
Sub Demo1()
    
    resimyolu = ThisWorkbook.Path & "\FOTOĞRAFLAR\"
    
    Sayfa1.OLEObjects.Delete
   
    sat = [a100000].End(3).Row
    
    For s = 2 To sat
    
        DoEvents
        
        If Dir(resimyolu & Cells(s, "d") & ".jpeg") <> "" Then uzanti = ".jpeg"
        If Dir(resimyolu & Cells(s, "d") & ".jpg") <> "" Then uzanti = ".jpg"
        
        If uzanti <> "" Then
            
            Set p = ActiveSheet.OLEObjects.Add( _
                        ClassType:="Forms.Image.1", _
                        Left:=Cells(s, "e").Left + 4, _
                        Top:=Cells(s, "e").Top + 4, _
                        Width:=Cells(s, "e").RowHeight - 9, _
                        Height:=Cells(s, "e").RowHeight - 9)
            
            Set r = p.Object
            
            r.PictureSizeMode = fmPictureSizeModeStretch
            r.Picture = LoadPicture(resimyolu & Cells(s, "d") & uzanti)
            
        End If
        
        uzanti = ""
        
    Next
    
End Sub

Satırların yüksekliğini artırırsanız resimler de satır yüksekliğine göre büyüyecektir.


.
 

Ekli dosyalar

bende farklı bir uygulama ile yardımcı olmak isterim.
 

Ekli dosyalar

Alternatif kod

Bir modül ekleyin içine bu kodu yapıştırıp kamut düğmesine bağlayın.

Kod: 
Option Explicit

Sub resim_getir()


'If Target.Row Mod 2 = 2 Then Exit Sub
Application.ScreenUpdating = False
Dim yer, i, deg1, resimyükle, yatay, dikey
Dim Resim As OLEObject
Dim Yeni_Resim As OLEObject
Dim Adres As Range
Dim Dosya_Yolu As String
Dim Resim_Adı As String
Dim sat, sut, deg, deg2
Dosya_Yolu = ThisWorkbook.Path & "\FOTOĞRAFLAR\"
Dim s1
Set s1 = Sheets(ActiveSheet.Name)



'On Error Resume Next
For sat = 2 To s1.Cells(Rows.Count, "B").End(3).Row


sut = 5

Resim_Adı = Cells(sat, sut - 1).Value 'Target.Value ' & ".jpg"
Dim uzanti(3)
uzanti(1) = "jpeg": uzanti(2) = "JPG": uzanti(3) = "jpg"
Set Adres = Range(Cells(sat, sut).Address, Cells(sat, sut).Address)

deg = 0
Dim Picture As Object
For Each Picture In s1.Shapes
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object) = "OLEObject" Then
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object.Object) = "Image" Then
yer = Cells(Picture.BottomRightCell.Row, Picture.BottomRightCell.Column).Address
If Not Intersect(Range(yer), Adres) Is Nothing Then


For i = 1 To 3
resimyükle = Dosya_Yolu & Resim_Adı & "." & uzanti(Val(i))
If CreateObject("Scripting.FileSystemObject").FileExists(resimyükle) = True Then
s1.Shapes(Picture.Name).OLEFormat.Object.Object.Picture = LoadPicture(resimyükle)

Exit For
End If
Next i
'Picture.Delete
deg = 1
Exit For
End If
End If
End If
Next Picture

deg2 = 0
For i = 1 To 3
resimyükle = Dosya_Yolu & Resim_Adı & "." & uzanti(Val(i))

If CreateObject("Scripting.FileSystemObject").FileExists(resimyükle) = True Then

If deg = 0 Then
Set Yeni_Resim = ActiveSheet.OLEObjects.Add(ClassType:="Forms.Image.1", Link:=False, _
DisplayAsIcon:=False, Left:=Adres.Left, Top:=Adres.Top, Width:=Adres.Width, Height:=Adres.Height)
With Yeni_Resim
.Top = Adres.Top + 1
.Left = Adres.Left + 1
.Height = Adres.Height - 2
.Width = Adres.Width - 2
.Object.PictureSizeMode = fmPictureSizeModeStretch
End With

Yeni_Resim.Object.Picture = LoadPicture(resimyükle)

End If
deg2 = 1
Exit For
Else

End If
Next i


If deg2 = 0 Then
For Each Picture In s1.Shapes
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object) = "OLEObject" Then
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object.Object) = "Image" Then
yer = Cells(Picture.BottomRightCell.Row, Picture.BottomRightCell.Column).Address
If Not Intersect(Range(yer), Adres) Is Nothing Then
Picture.Delete
deg = 1
Exit For
End If
End If
End If
Next Picture
End If

Next sat
Application.ScreenUpdating = True

End Sub

Sub resim_sil()
Dim s1
Set s1 = Sheets(ActiveSheet.Name)
Dim Picture As Object
For Each Picture In s1.Shapes
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object) = "OLEObject" Then
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object.Object) = "Image" Then
Picture.Delete
End If
End If
Next Picture
End Sub


Sayfanın kod bölümü içinde bu kodu yapıştırın.

Kod: 
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)

If Intersect(Target, [d2:d65536]) Is Nothing Then Exit Sub
'If Target.Row Mod 2 = 2 Then Exit Sub
Application.ScreenUpdating = False
Dim yer, i, deg1, resimyükle, yatay, dikey
Dim Resim As OLEObject
Dim Yeni_Resim As OLEObject
Dim Adres As Range
Dim Dosya_Yolu As String
Dim Resim_Adı As String
Dim sat, sut, deg, deg2

Dim s1
Set s1 = Sheets(ActiveSheet.Name)

If InStr(Trim(ActiveWindow.RangeSelection.Address), ":") <> 0 Then Exit Sub
yatay = -1 ' bu kadar hücre sağa kayacak
dikey = 1 ' bu kadar hücre aşağıya kayacak
sat = ActiveWindow.Selection.Row
sut = ActiveWindow.Selection.Column

'On Error Resume Next
Dosya_Yolu = ThisWorkbook.Path & "\FOTOĞRAFLAR\"
Resim_Adı = Cells(sat + yatay, sut).Value 'Target.Value ' & ".jpg"
Dim uzanti(3)
uzanti(1) = "jpeg": uzanti(2) = "JPG": uzanti(3) = "jpg"
Set Adres = Range(Cells(sat + yatay, sut + dikey).Address, Cells(sat + yatay, sut + dikey).Address)

deg = 0
Dim Picture As Object
For Each Picture In s1.Shapes
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object) = "OLEObject" Then
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object.Object) = "Image" Then
yer = Cells(Picture.BottomRightCell.Row, Picture.BottomRightCell.Column).Address
If Not Intersect(Range(yer), Adres) Is Nothing Then


For i = 1 To 3
resimyükle = Dosya_Yolu & Resim_Adı & "." & uzanti(Val(i))
If CreateObject("Scripting.FileSystemObject").FileExists(resimyükle) = True Then
s1.Shapes(Picture.Name).OLEFormat.Object.Object.Picture = LoadPicture(resimyükle)

Exit For
End If
Next i
'Picture.Delete
deg = 1
Exit For
End If
End If
End If
Next Picture

deg2 = 0
For i = 1 To 3
resimyükle = Dosya_Yolu & Resim_Adı & "." & uzanti(Val(i))

If CreateObject("Scripting.FileSystemObject").FileExists(resimyükle) = True Then

If deg = 0 Then
Set Yeni_Resim = ActiveSheet.OLEObjects.Add(ClassType:="Forms.Image.1", Link:=False, _
DisplayAsIcon:=False, Left:=Adres.Left, Top:=Adres.Top, Width:=Adres.Width, Height:=Adres.Height)
With Yeni_Resim
.Top = Adres.Top + 1
.Left = Adres.Left + 1
.Height = Adres.Height - 2
.Width = Adres.Width - 2
.Object.PictureSizeMode = fmPictureSizeModeStretch
End With

Yeni_Resim.Object.Picture = LoadPicture(resimyükle)

End If
deg2 = 1
Exit For
Else

End If
Next i


If deg2 = 0 Then
For Each Picture In s1.Shapes
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object) = "OLEObject" Then
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object.Object) = "Image" Then
yer = Cells(Picture.BottomRightCell.Row, Picture.BottomRightCell.Column).Address
If Not Intersect(Range(yer), Adres) Is Nothing Then
Picture.Delete
deg = 1
Exit For
End If
End If
End If
Next Picture
End If


Application.ScreenUpdating = True

End Sub

Private Sub CommandButton1_Click()
Dim s1
Set s1 = Sheets(ActiveSheet.Name)
Dim Picture As Object
For Each Picture In s1.Shapes
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object) = "OLEObject" Then
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object.Object) = "Image" Then
Picture.Delete
End If
End If
Next Picture
End Sub
 
yardımlarınız için çok teşekkür ederim, son 2 gün bakamadım foruma, çok işime yaradı, bilgi paylaşımı için çok çok teşekkür ederim sizlere ...
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst