• DİKKAT

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

Personel resimlerini toplu olarak getirme

ASLAN7410

ASLAN7410

Katılım
15 Temmuz 2012
Mesajlar
2,802
Excel Vers. ve Dili
Ofis 2021 TR 64 Bit
Merhaba herkese hayırlı geceler.

Ekte göndermiş olduğum klasör içerisinde personel resimleri ve örnek dosyam var.

Örnek dosyasının 1.sayfasında personel listesi var, alt sayfa olarakta büroların isimleri mevcut, bu sayfalardaki D sütünundaki aşağı doğru uzayıp giden sicilleri yazan personellerin resimlerini B sütununa toplu olarak getirmek istiyorum.

Bu konuyla ilgili forumda çok örnekler var, makrodan fazla anlamadığım için kendi dosyama uyarlayamadım.

Yardımcı olur musunuz?
.
http://dosya.co/7hfcika8ww1s/PERSONEL.rar.html
.
 

Ekli dosyalar

Son düzenleme:
İlk çalışma anında resimlerin olduğu klasördeki tüm resimleri seçin. Ctrl+a gibi

Program sayfa adında BÜROSU geçen tüm sayfaları tarayıp ilgili sicil numaralarına uyan dosyaları ekleyecektir.
Burada önemli olan B4:B8 gibi her kayıtta B hücreleri bileştiriliş olmalı.

Kod: 
Sub coklu_resim_yukleme()
  Dim PicList() As Variant
  Dim PicFormat As String
  Dim rng As Range
  Dim sShape As Shape
  Dim cel As Range
  Dim selectedRange As Range
  Dim sTemp As String
  Dim MyRange As Range

  On Error Resume Next
  PicList = Application.GetOpenFilename(PicFormat, MultiSelect:=True)
  If IsArray(PicList) Then
     For j = Len(PicList(1)) To 1 Step -1
         If Mid(PicList(1), j, 1) = "\" Then
            yol = Mid(PicList(1), 1, j)
           Exit For
         End If
     Next j
    
  For i1 = 1 To Sheets.Count
    Sheets(i1).Select
    If InStr(Sheets(i1), "BÜROSU") > 0 Then
      sonsatir = Cells(Rows.Count, "D").End(3).Row
      Set MyRange = Range("B1:B" & sonsatir)
      For Each sShape In ActiveSheet.Shapes
        If Not Intersect(Range(sShape.TopLeftCell.Address), MyRange) Is Nothing Then
           If sShape.Type <> 8 And sShape.Type <> 12 Then
              sShape.Delete
           End If
        End If
      Next
  
  
      i = 0

      For i = 1 To sonsatir
       bilgi = Cells(i, "C").Value
       If bilgi = "Sicil" Then
          dosyaadi = yol & Cells(i, "D").Value & ".jpg"
          For j = 1 To UBound(PicList)
            If dosyaadi = PicList(j) Then
               Set rng = Cells(i, "B")
               rng.Select
               Set sShape = ActiveSheet.Shapes.AddPicture(PicList(j), msoFalse, msoCTrue, Selection.Left, Selection.Top, Selection.Width, Selection.Height)
               Exit For
            End If
          Next j
        End If
      Next i
   End If
 Next i1
  End If
End Sub
 
Sayın asri, ilginiz için çok teşekkür ediyorum, kod örnek dosyada gayet güzel çalışıyor, ellerinize sağlık, tam istediğim gibi oldu.

Orijinal dosyamda kodu uygulayıp, daha sonra dönüş yapacağım.
 
Bu mesaj silindi.
 
Son düzenleme:
Sayın asri, yazdığınız kod gerçekten çok işime yaradı, çok teşekkür ederim, hayırlı çalışmalar, hayırlı günler diliyorum.
 
Arkadaşlar konu aynı olduğu için yeni konu açmadım.

Ekte gönderdiğim excel dosyasının 1.sayfasında çalışan personel bilgileri var, 2.sayfasında ayrılan personellere ait bilgiler mevcut.

Yapmak istediğim butona bastığımda kendimin seçebileceğim bir klasör içerisindeki personellere ait resimleri toplu olarak sicillerine göre B sütununa getirmek istiyorum.

İlk mesajımdaki örneğe Sayın asri Bey cevap yazmıştı, kod gayet güzel çalışıyor, çokta işime yaradı.

Şimdide böyle bir şeye gerek olduğu için örnek gönderiyorum.

Yardımcı olur musunuz?
.
 

Ekli dosyalar

ASLAN7410' Alıntı:
Arkadaşlar konu aynı olduğu için yeni konu açmadım.

Ekte gönderdiğim excel dosyasının 1.sayfasında çalışan personel bilgileri var, 2.sayfasında ayrılan personellere ait bilgiler mevcut.

Yapmak istediğim butona bastığımda kendimin seçebileceğim bir klasör içerisindeki personellere ait resimleri toplu olarak sicillerine göre B sütununa getirmek istiyorum.

İlk mesajımdaki örneğe Sayın asri Bey cevap yazmıştı, kod gayet güzel çalışıyor, çokta işime yaradı.

Şimdide böyle bir şeye gerek olduğu için örnek gönderiyorum.

Yardımcı olur musunuz?
.
Genişletmek için tıkla ...

Resim sil işlemini ayrıca yapmanıza gerek yok.
Resimleri yüklemeden önce siliyor.
Kontrol ediniz.


Kod: 
Sub coklu_resim_yukleme2()
  Dim PicList() As Variant
  Dim PicFormat As String
  Dim rng As Range
  Dim sShape As Shape
  Dim cel As Range
  Dim selectedRange As Range
  Dim sTemp As String
  Dim MyRange As Range
  Dim bilgi As String
  
  On Error Resume Next
  PicList = Application.GetOpenFilename(PicFormat, MultiSelect:=True)

  sayi = 0
  sayi = UBound(PicList)
  If sayi <= 0 Then
     MsgBox ("Resim seçimi yapılmadı")
     Exit Sub
  End If
  
  If IsArray(PicList) Then
     For j = Len(PicList(1)) To 1 Step -1
         If Mid(PicList(1), j, 1) = "\" Then
            yol = Mid(PicList(1), 1, j)
           Exit For
         End If
     Next j
 
     sonsatir = Cells(Rows.Count, "C").End(3).Row
      Set MyRange = Range("B2:B" & sonsatir)
      For Each sShape In ActiveSheet.Shapes
        If Not Intersect(Range(sShape.TopLeftCell.Address), MyRange) Is Nothing Then
           If sShape.Type <> 8 And sShape.Type <> 12 Then
              sShape.Delete
           End If
        End If
      Next
  
  
      i = 0

      For i = 2 To sonsatir
       bilgi = Cells(i, "C").Value
       If bilgi <> "" Then
          'dosyaadi = yol & Cells(i, "C").Value & " " & Cells(i, "D").Value & ".jpg"
          For j = 1 To UBound(PicList)
          [COLOR=Blue]  yeniisim = Mid(PicList(j), InStrRev(PicList(j), "\") + 1, Len(PicList(j)))
            yeniisim = Left(yeniisim, InStr(yeniisim, " ") - 1)
            If bilgi = yeniisim Then[/COLOR]
               Set rng = Cells(i, "B")
               rng.Select
               Set sShape = ActiveSheet.Shapes.AddPicture(PicList(j), msoFalse, msoCTrue, Selection.Left, Selection.Top, Selection.Width, Selection.Height)
               Exit For
            End If
          Next j
        End If
      Next i
  End If
End Sub
 
Son düzenleme:
Sayın asri Bey, Allah razı olsun, ellerinize sağlık çok güzel oldu, çok teşekkür ediyorum.

Hayırlı geceler, hayırlı çalışmalar diliyorum.
 
Sayın asri Bey, mesaj 7'deki kodu kendi orijinal dosyama uyguladım, süper bir şekilde çalışıyor, ellerinize sağlık.

Ancak küçük bir sorun var, bu sorunu düzeltebilir misiniz?

Sayfa üzerindeki Resimleri getir butonuna bastığımda, ekrana Aç diyalog penceresi geliyor, burada işlemden vazgeçtiğimizde yani iptal dediğimizde excel sayfasındaki resimleri de siliyor.

Aç diyalog penceresindeki iptal butonuna bastığımızda İşlemi iptal ettiniz gibi bir mesaj gelse ve sayfa üzerindeki önceki resimleri silmesin istiyorum.
.
 

Ekli dosyalar

ASLAN7410' Alıntı:
Sayın asri Bey, mesaj 7'deki kodu kendi orijinal dosyama uyguladım, süper bir şekilde çalışıyor, ellerinize sağlık.

Ancak küçük bir sorun var, bu sorunu düzeltebilir misiniz?

Sayfa üzerindeki Resimleri getir butonuna bastığımda, ekrana Aç diyalog penceresi geliyor, burada işlemden vazgeçtiğimizde yani iptal dediğimizde excel sayfasındaki resimleri de siliyor.

Aç diyalog penceresindeki iptal butonuna bastığımızda İşlemi iptal ettiniz gibi bir mesaj gelse ve sayfa üzerindeki önceki resimleri silmesin istiyorum.
.
Genişletmek için tıkla ...

Br önceki mesajda kırmızı yazılı kodu ekleyiniz.
 
Sayın asri Bey, ellerinize sağlık, valla süper oldu, çok teşekkür ediyorum.

Hayırlı çalışmalar, hayırlı geceler diliyorum.
 
Sayın Asri Bey, hayırlı geceler.

Bu konu ile bir ihtiyaç daha ortaya çıktığı için tekrar konu açmadım.

Önceki kodlar çok güzel çalışıyor, ellerinize sağlık.

Örneği gönderiyorum, resimlerin bulunduğu klasör içerisindeki personel resimlerinin yanına isimlerini de yazdığımda resimleri getirmedi, bu şekilde yazmamın sebebi sicili bulunan kişilerin kim olduğu belli olmadığı için sicillerinin yanına isimlerini de yazmak durumundayım.

Kodun neresini düzeltmeliyim ki, resimler gelsin?

Resmin adı örneğin, 111111 Ali VELİ, 222222 Hasan ALİ gibi yazmıştım.
.
 

Ekli dosyalar

Kod güncellendi. Mavi olarak işaretlendi.
 
Sayın Asri Bey, Allah razı olsun, süper oldu çok teşekkür ediyorum.

Hayırlı çalışmalar, hayırlı geceler diliyorum.
 
Sayın Asri Bey, tekrar rahatsız ediyorum, kusura bakmayın.

Excel sayfasındaki D sütunundaki isimler resimdeki isimle birebir aynı olmadığı için bazı resimleri getirmiyor.

Excel sayfasının D sütununda bazı isimler kısa yazılmış, bazılarının arasında fazla boşluk var, yani excel sayfasındaki isimler düzensiz, ama sicillerde bir sorun yok, sadece C sütunundaki sicilleri resimlerdeki siciller ile karşılaştırıp resmi getirirse tam istediğim gibi olacak.
 

Ekli dosyalar

  • Resim.jpg
    Resim.jpg
    12.7 KB · Görüntüleme: 13
Son düzenleme:
ASLAN7410' Alıntı:
Sayın Asri Bey, tekrar rahatsız ediyorum, kusura bakmayın.

Excel sayfasındaki D sütunundaki isimler resimdeki isimle birebir aynı olmadığı için bazı resimleri getirmiyor.

Excel sayfasının D sütununda bazı isimler kısa yazılmış, bazılarının arasında fazla boşluk var, yani excel sayfasındaki isimler düzensiz, ama sicillerde bir sorun yok, sadece C sütunundaki sicilleri resimlerdeki siciller ile karşılaştırıp resmi getirirse tam istediğim gibi olacak.
Genişletmek için tıkla ...

7. mesajda dosya güncellendi. Kontrol ediniz.

Dosya isimlerinde ilk boşluğua kadar olan bilgi alınmaktadır. Bu yüzden mutlaka dosya isimlerinde sicilden sonra bir boşluk olmalıdır.
 
Sayın Asri Bey, çok teşekkür ediyorum, ellerinize sağlık şimdi tam istediğim gibi oldu.

Hayırlı geceler, hayırlı çalışmalar diliyorum.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst