Excel Forum
ALTIN ÜYELİK Hakkında Bilgi


Geri Git   Excel Forum > EXCEL-Soruları > Makro-VBA
Atatürk
Şifremi Unuttum

DUYURU SİSTEMİ / REKLAM PANOSU

Makro-VBA Makro veya VBA ile ilgili sorularınızı buraya gönderebilirsiniz.
Dosya ekleyebilirsiniz

Özel Arama


Yanıtla
 
Paylaş Konu Araçları Görünüm Modları
Eski 27-09-2017, 22:50   #1
ASLAN7410
Altın Üye
 
ASLAN7410 kullanıcısının avatarı
 
Giriş: 15/07/2012
Şehir: Aslan ERASLAN - ANKARA
Mesaj: 1,520
Excel Vers. ve Dili:
Ofis 2013 Türkçe
Varsayılan Personel resimlerini toplu olarak getirme

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
.
Eklenmiş Dosyalar
Dosya Türü: rar PERSONEL.rar (433.8 KB, 30 Görüntülenme)
__________________
.
Her zaman yardımcı olmak güzel bir şeydir...

Bu mesaj en son " 27-09-2017 " tarihinde saat 23:09 itibariyle ASLAN7410 tarafından düzenlenmiştir....
ASLAN7410 Çevrimdışı   Alıntı Yaparak Cevapla
Eski 28-09-2017, 00:32   #2
asri
Altın Üye
 
Giriş: 24/04/2005
Şehir: Istanbul
Mesaj: 2,367
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
Eski 28-09-2017, 00:40   #3
ASLAN7410
Altın Üye
 
ASLAN7410 kullanıcısının avatarı
 
Giriş: 15/07/2012
Şehir: Aslan ERASLAN - ANKARA
Mesaj: 1,520
Excel Vers. ve Dili:
Ofis 2013 Türkçe
Varsayılan

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.
__________________
.
Her zaman yardımcı olmak güzel bir şeydir...
ASLAN7410 Çevrimdışı   Alıntı Yaparak Cevapla
Eski 28-09-2017, 02:24   #4
ASLAN7410
Altın Üye
 
ASLAN7410 kullanıcısının avatarı
 
Giriş: 15/07/2012
Şehir: Aslan ERASLAN - ANKARA
Mesaj: 1,520
Excel Vers. ve Dili:
Ofis 2013 Türkçe
Varsayılan

Bu mesaj silindi.
__________________
.
Her zaman yardımcı olmak güzel bir şeydir...

Bu mesaj en son " 28-09-2017 " tarihinde saat 04:39 itibariyle ASLAN7410 tarafından düzenlenmiştir....
ASLAN7410 Çevrimdışı   Alıntı Yaparak Cevapla
Eski 28-09-2017, 13:59   #5
ASLAN7410
Altın Üye
 
ASLAN7410 kullanıcısının avatarı
 
Giriş: 15/07/2012
Şehir: Aslan ERASLAN - ANKARA
Mesaj: 1,520
Excel Vers. ve Dili:
Ofis 2013 Türkçe
Varsayılan

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.
__________________
.
Her zaman yardımcı olmak güzel bir şeydir...
ASLAN7410 Çevrimdışı   Alıntı Yaparak Cevapla
Eski 29-09-2017, 20:46   #6
ASLAN7410
Altın Üye
 
ASLAN7410 kullanıcısının avatarı
 
Giriş: 15/07/2012
Şehir: Aslan ERASLAN - ANKARA
Mesaj: 1,520
Excel Vers. ve Dili:
Ofis 2013 Türkçe
Varsayılan

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?
.
Eklenmiş Dosyalar
Dosya Türü: rar PERSONEL1.rar (370.3 KB, 10 Görüntülenme)
__________________
.
Her zaman yardımcı olmak güzel bir şeydir...
ASLAN7410 Çevrimdışı   Alıntı Yaparak Cevapla
Eski 29-09-2017, 21:03   #7
asri
Altın Üye
 
Giriş: 24/04/2005
Şehir: Istanbul
Mesaj: 2,367
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 Çevrimdışı   Alıntı Yaparak Cevapla
Eski 29-09-2017, 21:13   #8
ASLAN7410
Altın Üye
 
ASLAN7410 kullanıcısının avatarı
 
Giriş: 15/07/2012
Şehir: Aslan ERASLAN - ANKARA
Mesaj: 1,520
Excel Vers. ve Dili:
Ofis 2013 Türkçe
Varsayılan

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.
__________________
.
Her zaman yardımcı olmak güzel bir şeydir...
ASLAN7410 Çevrimdışı   Alıntı Yaparak Cevapla
Eski 01-10-2017, 19:28   #9
ASLAN7410
Altın Üye
 
ASLAN7410 kullanıcısının avatarı
 
Giriş: 15/07/2012
Şehir: Aslan ERASLAN - ANKARA
Mesaj: 1,520
Excel Vers. ve Dili:
Ofis 2013 Türkçe
Varsayılan

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.
.
Eklenmiş Dosyalar
Dosya Türü: rar PERSONEL1.rar (490.7 KB, 10 Görüntülenme)
__________________
.
Her zaman yardımcı olmak güzel bir şeydir...
ASLAN7410 Çevrimdışı   Alıntı Yaparak Cevapla
Eski 01-10-2017, 20:17   #10
asri
Altın Üye
 
Giriş: 24/04/2005
Şehir: Istanbul
Mesaj: 2,367
Excel Vers. ve Dili:
Office 2016 TR 64 Bit
Varsayılan

Alıntı:
ASLAN7410 tarafından gönderildi Mesajı Görüntüle
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.
__________________
www.asriakdeniz.com
asri Çevrimdışı   Alıntı Yaparak Cevapla
Yanıtla


Konu Araçları
Görünüm Modları

Gönderme Kuralları
You may not post new threads
You may not post replies
You may not post attachments
You may not edit your posts

BB code is Açık
SimgelerAçık
[IMG] kodu Açık
HTML kodu Kapalı


Saat 10:38


Bu forum Elit NET - www.elitnet.com.tr tarafından sunulmaktadır.

Excel Eğitimi - Mobil Uygulama - Çorlu - Çorlu Web Tasarım - Tarot Falı - invest in turkey - Lingerie - Dyeing Machine - Karton Bardak- Çorlu Özel Eğitim- Site Yönetimi- Led Aydınlatma- Pronet Tekirdağ- Çorlu Kamera- Pronet Edirne- Pronet Kırklareli- Pronet Çerkezköy- Pronet Çorlu- Pronet Lüleburgaz- Pronet Keşan- Çorlu Araç Takip- Çorlu Su Arıtma- Boru Profil- Gebze Emlak- Beylikdüzü Temizlik- İstanbul Burun Estetiği- Bakır Sülfat- Rampa- Rotary- Çorlu İnternet Sitesi- youngblood- Çorlu Palet- Çerkezköy Palet- Çorlu Prefabrik- Çorlu Sürücü Kursu- Çorlu Sandviç Panel- Şişli Avukat- Korona Test Kalemi- Çorlu Vinç- Çorlu Pimapen Tamiri-
Powered by vBulletin Version 3.7.2
Copyright ©2000 - 2017, Jelsoft Enterprises Ltd.
Advertisement System V2.6 By   Branden