Excel Forum

Excel Forum (http://www.excel.web.tr/index.php)
-   Makro-VBA (http://www.excel.web.tr/forumdisplay.php?f=48)
-   -   Personel resimlerini toplu olarak getirme (http://www.excel.web.tr/showthread.php?t=166980)

ASLAN7410 27-09-2017 22:50

Personel resimlerini toplu olarak getirme
 
1 Eklenti(ler)
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
.

asri 28-09-2017 00:32

İ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


ASLAN7410 28-09-2017 00:40

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.

ASLAN7410 28-09-2017 02:24

Bu mesaj silindi.

ASLAN7410 28-09-2017 13:59

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.

ASLAN7410 29-09-2017 20:46

1 Eklenti(ler)
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?
.

asri 29-09-2017 21:03

Alıntı:

ASLAN7410 tarafından gönderildi (Mesaj 911166)
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?
.

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)
            yeniisim = Mid(PicList(j), InStrRev(PicList(j), "\") + 1, Len(PicList(j)))
            yeniisim = Left(yeniisim, InStr(yeniisim, " ") - 1)
            If bilgi = yeniisim 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
End Sub


ASLAN7410 29-09-2017 21:13

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.

ASLAN7410 01-10-2017 19:28

1 Eklenti(ler)
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 diyalog penceresi geliyor, burada işlemden vazgeçtiğimizde yani iptal dediğimizde excel sayfasındaki resimleri de siliyor.

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

asri 01-10-2017 20:17

Alıntı:

ASLAN7410 tarafından gönderildi (Mesaj 911364)
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 diyalog penceresi geliyor, burada işlemden vazgeçtiğimizde yani iptal dediğimizde excel sayfasındaki resimleri de siliyor.

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

Br önceki mesajda kırmızı yazılı kodu ekleyiniz.

ASLAN7410 01-10-2017 20:20

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.

ASLAN7410 23-10-2017 21:44

1 Eklenti(ler)
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.
.

asri 23-10-2017 21:50

Kod güncellendi. Mavi olarak işaretlendi.

ASLAN7410 23-10-2017 21:55

Sayın Asri Bey, Allah razı olsun, süper oldu çok teşekkür ediyorum.

Hayırlı çalışmalar, hayırlı geceler diliyorum.

ASLAN7410 23-10-2017 22:22

1 Eklenti(ler)
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.

asri 09-11-2017 07:54

Alıntı:

ASLAN7410 tarafından gönderildi (Mesaj 914341)
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.

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.

ASLAN7410 10-11-2017 19:39

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.


Saat 20:00

Powered by vBulletin Version 3.7.2
Copyright ©2000 - 2017, Jelsoft Enterprises Ltd.