logo ekleme

[spacebar]

değerli üstadlarım. aşağıda paylaştığım kodlarla resmi B3 : D6 aralığına ekliyor ve sorunsuz çalışıyor. ancak ben bu aralıkla birlikte (aynı zamanda) B17 : D20 aralığına da aynı resmi eklemek istiyorum. kodlarda nasıl bir revizyon yapmak gereklidir. yardımlarınız için teşekkür ederim.

Sub logoEkle()

Dim eskizoom As Integer
eskizoom = ActiveWindow.Zoom
On Error GoTo hata
Dosya1 = Application.GetOpenFilename(FileFilter:="," & _
        "*.jpeg;*.png;*.bmp;*.jpg;*.gif", _
        Title:="Resim seçimi yapınız")
    If Dosya1 = False Then
    MsgBox "Resim seçmediniz.", vbCritical, "                     ## UYARI ##"  'vbInformation
    Exit Sub
    Else
    End If
    Application.ScreenUpdating = False
    Range("B3:D6").Select
ActiveWindow.Zoom = 100   'Sayfa Yakınlaştırma Ayarı
Set Alan1 = ActiveCell 'Range("C3,G3,K3,O3,S3")    'Range("C3:C9")
    For Each Resim1 In ActiveSheet.Pictures
    If Not Intersect(Resim1.TopLeftCell, Alan1) Is Nothing Then
    Resim1.Delete
    End If
    Next
    Set Alan1 = Nothing
    ActiveCell.Select 'Cells(3, "C").Select
    Set Adres1 = Range(ActiveWindow.RangeSelection.Address)
    ActiveSheet.Shapes.AddPicture(Filename:=Dosya1, linktofile:=msoFalse, _
            savewithdocument:=msoCTrue, Left:=0, Top:=0, Width:=-1, Height:=-1).Select
    Selection.ShapeRange.Line.Visible = msoTrue
    Selection.ShapeRange.Line.Weight = 0  'Çerçeve Kalınlığı
    Selection.ShapeRange.Line.ForeColor.RGB = RGB(0, 112, 192)
    Selection.ShapeRange.LockAspectRatio = msoFalse
    Selection.ShapeRange.Height = Adres1.Height * 0.85 'Yükseklik Aralığı
    Selection.ShapeRange.Width = Adres1.Width * 0.85   'Saş - Sol Aralık
    Selection.Top = Adres1.Top + 2 + (Adres1.Height - Selection.ShapeRange.Height) / 2
    Selection.Left = Adres1.Left + (Adres1.Width - Selection.ShapeRange.Width) / 2
        ActiveWindow.Zoom = eskizoom
        Application.ScreenUpdating = True
        Application.CutCopyMode = False
   
    'MsgBox "Firma Bilgilerini Girmeyi Unutmayınız.", vbCritical, "UYARI"

    Exit Sub
hata:
    MsgBox "Resim Ekleme için Hatalı İşlem Yapıldı.", vbCritical, "UYARI"
   
End Sub

 

[spacebar]

değerli üstadlarım konuya çözüm bulamadım.