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

İ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: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
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
__________________
www.asriakdeniz.com
asri Çevrimdışı   Alıntı Yaparak Cevapla