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 09-02-2018, 09:38   #1
anemis
Altın Üye
 
Giriş: 10/10/2013
Şehir: Ankara
Mesaj: 155
Excel Vers. ve Dili:
Excel 2016
Varsayılan Otomatik Resim Ekleme

Merhabalar,

Ekli dosyada detaylıca anlatmaya çalıştım. İnşallah yeterli açıklamam olmuştur.

Özet olarak;
Bilgisayarımdaki herhangi bir klasördeki çokça resimi belirli bir düzende excel içine atmak istiyorum. (her bir resimi ekleneceği hücre pattern i aynı. Örneğin 01.jpg resmi B52:Y98 hücreleri arasında strechlenecek ise (bu hücreler birleştirilerek tek bir hücre de olabilir) 02.jpg resmi B52 den 50 satır sonra yani B102 ve Y98 den yine 50 satır sonra Y148 e yani B102:Y148 e gelmeli.
Aynı şekilde 03.jpg resmi yine 50 satır sonrasına B152:Y198 e gelmeli vs.

Onlarca resmi tek tek ekleyip çıktıya hazır hale getirmek inanılmaz yorucu olmaya başladı. Yardımcı olabilicek, fikir verebilecek herkese sonsuz teşekkürler.
Eklenmiş Dosyalar
Dosya Türü: rar OtomatikResim.rar (256.9 KB, 8 Görüntülenme)
anemis Çevrimdışı   Alıntı Yaparak Cevapla
Eski 09-02-2018, 09:56   #2
askm
Altın Üye
 
Giriş: 04/06/2005
Şehir: k.maraş
Mesaj: 1,967
Excel Vers. ve Dili:
2010-2016
Varsayılan

Resimleri sırası ile alması için sizin resimlerin isimlerini farklı bir sheete sırası ile alt alta yazmanız gerekir. Ya da öncelikle resim isimlerini başka bir sayfaya çektirip sıralam yaptırıp ona göre ekleme yapmak gerekir. (Bu şekilde belki istediğiniz sonucu tam olarak vermez.) Sonrasında belirttiğiniz gibi hücre birleştirip resim eklenebilir.
__________________
excel 2010- türkçe
askm Çevrimiçi   Alıntı Yaparak Cevapla
Eski 09-02-2018, 09:58   #3
anemis
Altın Üye
 
Giriş: 10/10/2013
Şehir: Ankara
Mesaj: 155
Excel Vers. ve Dili:
Excel 2016
Varsayılan

Değerli katkınız için teşekkür ederim sayın askm, resimlerin isimlerinin de bir şablonu var aslında, gerçi çok önemli de değil. gerekli ise isimleri bir sayfaya yada belli bir yere elle girebilirim. yada listeleme makrosu da bu işimi çöze diye düşünüyorum.
anemis Çevrimdışı   Alıntı Yaparak Cevapla
Eski 09-02-2018, 10:01   #4
askm
Altın Üye
 
Giriş: 04/06/2005
Şehir: k.maraş
Mesaj: 1,967
Excel Vers. ve Dili:
2010-2016
Varsayılan

Belirttiğiniz gibi isimleri girerek tekrar dosyanızı ekleyebilir misiniz?
__________________
excel 2010- türkçe
askm Çevrimiçi   Alıntı Yaparak Cevapla
Eski 09-02-2018, 10:11   #5
anemis
Altın Üye
 
Giriş: 10/10/2013
Şehir: Ankara
Mesaj: 155
Excel Vers. ve Dili:
Excel 2016
Varsayılan

Alıntı:
askm tarafından gönderildi Mesajı Görüntüle
Belirttiğiniz gibi isimleri girerek tekrar dosyanızı ekleyebilir misiniz?
Tabii ki,

Belirli bir formülasyonla excel dosyasının içine ekledim. Oradan zaten şablonu algılayabilirsiniz.

Zamanınız ve yardımınız için teşekkürler.
Eklenmiş Dosyalar
Dosya Türü: rar OtomatikResim.rar (258.0 KB, 5 Görüntülenme)
anemis Çevrimdışı   Alıntı Yaparak Cevapla
Eski 09-02-2018, 10:25   #6
askm
Altın Üye
 
Giriş: 04/06/2005
Şehir: k.maraş
Mesaj: 1,967
Excel Vers. ve Dili:
2010-2016
Varsayılan

Aşağıdaki kodları bir modüle yapıştırıp deneyin. Belirttiğiniz formatta değil de resim isimleri 01-02 şeklinde gittiğiniz varsayarak kod yazdım.
Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
Sub askm()
Call Belirli_Bir_Alandaki_Resimleri_Sil
Klasor = ThisWorkbook.Path & "\"
On Error Resume Next
Satir = 52
For i = 1 To 6
    If i < 10 Then
        dosya = Klasor & "0" & i & ".jpg"
    Else
        dosya = Klasor & i & ".jpg"
    End If
    Range(Cells(Satir, 2), Cells(Satir + 46, "Y")).Select
    Range(Cells(Satir, 2), Cells(Satir + 46, "Y")).Merge
    ActiveSheet.Pictures.Insert(dosya).Select
    With Selection
            .ShapeRange.LockAspectRatio = msoFalse
            .Top = Range(Cells(Satir, 2), Cells(Satir + 46, "Y")).Top
            .Left = Range(Cells(Satir, 2), Cells(Satir + 46, "Y")).Left
            .Width = Range(Cells(Satir, 2), Cells(Satir + 46, "Y")).Width
            .Height = Range(Cells(Satir, 2), Cells(Satir + 46, "Y")).Height
    End With
    Satir = Satir + 50
Next i
End Sub


Sub Belirli_Bir_Alandaki_Resimleri_Sil()
    Dim Resim As Picture, Alan As Range
    Set Alan = Range("B52:Y65536")
    For Each Resim In ActiveSheet.Pictures
        If Not Intersect(Resim.TopLeftCell, Alan) Is Nothing Then
            Resim.Delete
        End If
    Next
    Set Alan = Nothing
End Sub
__________________
excel 2010- türkçe
askm Çevrimiçi   Alıntı Yaparak Cevapla
Eski 09-02-2018, 10:35   #7
anemis
Altın Üye
 
Giriş: 10/10/2013
Şehir: Ankara
Mesaj: 155
Excel Vers. ve Dili:
Excel 2016
Varsayılan

Emeklerinize sağlık üstadım, ancak ne yazık ki modüle ekleyip çalıştır diyorum kodları, bir sonuç alamıyorum.
anemis Çevrimdışı   Alıntı Yaparak Cevapla
Eski 09-02-2018, 10:41   #8
askm
Altın Üye
 
Giriş: 04/06/2005
Şehir: k.maraş
Mesaj: 1,967
Excel Vers. ve Dili:
2010-2016
Varsayılan

Dosyanız ektedir.
Eklenmiş Dosyalar
Dosya Türü: xlsm Resim Ekleme.xlsm (42.1 KB, 12 Görüntülenme)
__________________
excel 2010- türkçe
askm Çevrimiçi   Alıntı Yaparak Cevapla
Eski 09-02-2018, 10:45   #9
anemis
Altın Üye
 
Giriş: 10/10/2013
Şehir: Ankara
Mesaj: 155
Excel Vers. ve Dili:
Excel 2016
Varsayılan

Sayın askm üstadım çok teşekkür ederim. Harikasınız. Aslında bu benim işimi oldukça kolaylaştıracak. Emeklerinize sağlık.

Artık bir miktar daha şımararak biraz kodu geliştirebilir miyiz acaba diye sormak istiyorum?

1) Resimlerin ekleneceği klasörü ben seçemez miyim? excel ile resimler aynı klasörde olmuyor her zaman.
2) Resim ekleme gibi bir button olsa dosyanın içerisinde. ona tıklayınca resimleri seçtirse ve otomatik eklese olur mu?
anemis Çevrimdışı   Alıntı Yaparak Cevapla
Eski 09-02-2018, 14:04   #10
askm
Altın Üye
 
Giriş: 04/06/2005
Şehir: k.maraş
Mesaj: 1,967
Excel Vers. ve Dili:
2010-2016
Varsayılan

Dosyadaki kodları aşağıdaki kodlar ile değiştirin. Sayfanıza AA sütunundan sonra olmak üzere bir şekil ekleyin. Şekli istediğiniz gibi biçimlendirin. Sağ tıklayın.Makro ata deyin ve makro olarak "ASKM_RESİM_GETİR" seçin.

Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
Sub ASKM_RESİM_GETİR()
Dim Kaynak As String
Dim askm As FileDialog

    Set askm = Application.FileDialog(msoFileDialogFolderPicker)
    askm.AllowMultiSelect = False
    askm.Show
    Kaynak = askm.SelectedItems(1)
    If Kaynak = Empty Or InStr(1, Kaynak, "{") > 0 Then GoTo Atla


Call Belirli_Bir_Alandaki_Resimleri_Sil

On Error Resume Next
Satir = 52
For i = 1 To 6
    If i < 10 Then
        Dosya = Kaynak & "\" & "0" & i & ".jpg"
    Else
        Dosya = Kaynak & "\" & i & ".jpg"
    End If
    Range(Cells(Satir, 2), Cells(Satir + 46, "Y")).Select
    Range(Cells(Satir, 2), Cells(Satir + 46, "Y")).Merge
    ActiveSheet.Pictures.Insert(Dosya).Select
    With Selection
            .ShapeRange.LockAspectRatio = msoFalse
            .Top = Range(Cells(Satir, 2), Cells(Satir + 46, "Y")).Top
            .Left = Range(Cells(Satir, 2), Cells(Satir + 46, "Y")).Left
            .Width = Range(Cells(Satir, 2), Cells(Satir + 46, "Y")).Width
            .Height = Range(Cells(Satir, 2), Cells(Satir + 46, "Y")).Height
    End With
    Satir = Satir + 50
Next i
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız!", vbInformation, "ASKM"
End Sub


Sub Belirli_Bir_Alandaki_Resimleri_Sil()
    Dim Resim As Picture, Alan As Range
    
    Set Alan = Range("B52:Y65536")
    
    For Each Resim In ActiveSheet.Pictures
        If Not Intersect(Resim.TopLeftCell, Alan) Is Nothing Then
            Resim.Delete
        End If
    Next
    
    Set Alan = Nothing
    
End Sub
__________________
excel 2010- türkçe
askm Çevrimiçi   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 12:55


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

Excel Eğitimi - Mobil Uygulama - Çorlu - Çorlu Web Tasarım -- Beylikdüzü mali müşavir - Beylikdüzü mali müşavir - Lingerie - Dyeing Machine - Karton Bardak- Karton Bardak- Çorlu Dil Konuşma Terapisti- Çorlu Dil Konuşma Terapisti- Çorlu Konuşma Terapisti- Çorlu Konuşma Terapisti- Çorlu Özel Eğitim- Site Yönetimi- Pronet Tekirdağ- Çorlu Kamera- Pronet Edirne- Pronet Çorlu- Çorlu Araç Takip- Çorlu Su Arıtma- Gebze Emlak- Rampa- Rotary- Çorlu İnternet Sitesi- Çorlu Sürücü Kursu- Çorlu Sürücü Kursu- Şişli Avukat- Edirne Serbest Muhasebeci- Çorlu Etüt- İstanbul Botanik- Çorlu Sigorta- Kağıt Bardak- Kağıt Bardak- Kaplan Tekstil- Çorlu Perde- Çorlu Perde- Çorlu Havuz- Çorlu Havuz- Makina- Danışmazlar- Çorlu Perde Yıkama- Çorlu Perde Yıkama- Okul Danışmanlık- Çorlu Ayakkabı- İzmit Sigorta- ADR'li taşıma kabı imalatı- Mekanik Tesisat- Çorlu Grafik Tasarım-
Powered by vBulletin Version 3.7.2
Copyright ©2000 - 2018, Jelsoft Enterprises Ltd.
Advertisement System V2.6 By   Branden