Yalnız Mesajı Göster
Eski 29-09-2017, 21:03  
asri
Altın Üye
 
Giriş: 24/04/2005
Şehir: Istanbul
Mesaj: 2,369
Excel Vers. ve Dili:
Office 2016 TR 64 Bit
Varsayılan

Alıntı:
ASLAN7410 tarafından gönderildi Mesajı Görüntüle
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: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
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
__________________
www.asriakdeniz.com

Bu mesaj en son " 09-11-2017 " tarihinde saat 07:54 itibariyle asri tarafından düzenlenmiştir....
asri Çevrimiçi   Alıntı Yaparak Cevapla