Soru Makro İle Çoklu Resim Almak

[ormann]

İyi günler ekli resim dosyasında Resim-2 sayfasında B6:V27 ile B29:VC50 hücre aralığına 2 adet resim ; Resim-4 sayfasında B6:K27,M6:V27,B29:K50,M29:V50 hücre aralığına 4 adet resim,Resim-6 sayfasında B6:K21,M6:V21,B23:K38,M23:V38,B40:K55,M40:V55 hücre arsalığına 6 adet resim,Resim-8 sayfasında B6:K16,M6.V16,B18:K28,M18:V28,B30:K40,M30:V40,B42:K52,M42:V52 hücre aralığına makro ile dosyadan resim aldırabilir miyiz ?

İndir RESİM

Dosyayı indir RESİM

dosya.co

 

[Korhan Ayhan]

Resimler nerden alınacak? Dosya yolu nedir?

 

[ormann]

Resimler dosya açtan ben kendim seçeceğim hocam

 

[Korhan Ayhan]

Deneyiniz.

Bu kod 2 resim eklemek için kurgulandı.

Diğer kodlar için uyarlama yapmanız gerekiyor.

Güncellemeniz gereken alanlar;

For Each Resim In ActiveSheet.Pictures
If Not Intersect(Resim.TopLeftCell, Range("B6:V27")) Is Nothing Or _
Not Intersect(Resim.TopLeftCell, Range("B29:V50")) Is Nothing Then
Resim.Delete
End If
Next

If Say > 2 Then GoTo Son

Select Case Say
Case 1: Set Alan = Range("B6:V27")
Case 2: Set Alan = Range("B29:V50")
End Select

Option Explicit

Sub Resim_Ekle_2()
    Dim Dosya As Variant, X As Byte, Say As Byte, Resim As Variant, Alan As Range
    
    For Each Resim In ActiveSheet.Pictures
        If Not Intersect(Resim.TopLeftCell, Range("B6:V27")) Is Nothing Or _
            Not Intersect(Resim.TopLeftCell, Range("B29:V50")) Is Nothing Then
            Resim.Delete
        End If
    Next

    Dosya = Application.GetOpenFilename("*.jpg, *.jpg", , , , True)
    
    If IsArray(Dosya) = False Then
        MsgBox "Lütfen dosya seçimi yapınız!", vbCritical
        Exit Sub
    End If
    
    For X = LBound(Dosya) To UBound(Dosya)
        Say = Say + 1
        If Say > 2 Then GoTo Son
        Set Resim = ActiveSheet.Pictures.Insert(Dosya(X))
        
        Select Case Say
            Case 1: Set Alan = Range("B6:V27")
            Case 2: Set Alan = Range("B29:V50")
        End Select
        
        With Alan
            Resim.ShapeRange.LockAspectRatio = msoFalse
            Resim.Top = .Top + 0.1
            Resim.Left = .Left
            Resim.Height = .Height
            Resim.Width = .Width
        End With
    Next

Son:
    MsgBox "Resimler dosyaya aktarılmıştır.", vbInformation
End Sub

 

[ormann]

Korhan bey hocam çok teşekkür ederim.Ellerinize sağlık

 

[ormann]

Merhabalar;
Ekli dosyada belirli hücrelere resim alma makrosun da değişiklik yapmak istiyorum .Yardımcı olursanız sevinirim. Ben 3,4,5,6 ve 8 li olarak resim hücreleri belirledim .Fakat resim resmin üzerine geliyor. Aşağıda ki belirtmiş olduğum hücrelere resimler gelebilir mi?. Ayrıca resimlerin çerçeve rengi kırmızı kalınlığı ise 2 olacak.

Ekli dosyada tek bir buton ile aşağıdaki hücrelere 1,2,3,4,5,6, ve 8 resim aldırabilir miyiz?
1 Resim: B6:W49
2 Resim: B6:W27-B28:W49
3 Resim: B6:L27-M6:W27-B28:W49
4 Resim: B6:L27-M6:w27-B28:L49-M28:W49
5 Resim: B6:L20-M6:W20-B21:L35-M21:W35-B36:W49
6 Resmi: B6:L20-M6:W20-B21:L35-M21:W35-B36:L49-M36:W49
8 Resim : B6:L16-M6:W16-B17:L27- M17:W27-B28:L38-M28:38-B39:L49-M39:W49

https://dosya.co/3tz6q8b010ae/RESİM.xls.html