Yalnız Mesajı Göster
Eski 09-02-2018, 13:04  
askm
Altın Üye
 
Giriş: 04/06/2005
Şehir: K.Maraş
Mesaj: 2,119
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 Çevrimdışı   Alıntı Yaparak Cevapla