Excel hücre içindeki resmi rastgele çoğaltma

[mehmetaltin]

Arkadaşlar ekte verdiğim dosyadaki para resimlerini rastgele arada olacak şekilde nasıl çoğaltabilirim.

excel resim çoğaltma

 

[pitchoute]

Merhaba, istediğiniz bu şekilde mi dener misiniz;

Sub ParaResimleriniDuzgunYerlestir()
    Dim ws As Worksheet
    Dim kaynak As Range
    Dim hedefAralik As Range
    Dim i As Long, j As Long
    Dim rastgeleSayi As Integer
    Dim resimKoleksiyonu As Collection
    Dim resim As Shape
    Dim orijinalBoyutlar As Collection
    
    Application.ScreenUpdating = False
    
    Set ws = ActiveSheet
    
    On Error Resume Next
    For Each resim In ws.Shapes
        If resim.Left >= ws.Range("H1").Left And resim.Left <= ws.Range("K20").Left Then
            resim.Delete
        End If
    Next resim
    On Error GoTo 0
    
    Set kaynak = ws.Range("G1:G3")
    
    Set hedefAralik = ws.Range("H1:K15")
    
    Set resimKoleksiyonu = New Collection
    Set orijinalBoyutlar = New Collection
    
    For Each resim In ws.Shapes
        If resim.Left >= ws.Range("G1").Left And resim.Left <= ws.Range("G3").Left + ws.Range("G3").Width Then
            resimKoleksiyonu.Add resim
            Dim boyutlar(1 To 2) As Double
            boyutlar(1) = resim.Width
            boyutlar(2) = resim.Height
            orijinalBoyutlar.Add boyutlar
        End If
    Next resim
    
    If resimKoleksiyonu.Count = 0 Then
        MsgBox "G sütununda çoğaltılacak resim bulunamadı!", vbExclamation
        Application.ScreenUpdating = True
        Exit Sub
    End If
    
    For Each hucre In hedefAralik.Cells
        rastgeleSayi = Int((resimKoleksiyonu.Count * Rnd) + 1)
        Set resim = resimKoleksiyonu(rastgeleSayi).Duplicate
        Dim orijinalEn As Double, orijinalBoy As Double
        orijinalEn = orijinalBoyutlar(rastgeleSayi)(1)
        orijinalBoy = orijinalBoyutlar(rastgeleSayi)(2)
        
        With resim
            .Width = orijinalEn
            .Height = orijinalBoy
            .Left = hucre.Left + (hucre.Width - .Width) / 2
            .Top = hucre.Top + (hucre.Height - .Height) / 2
            
            If .Width > hucre.Width Then
                Dim oran As Double
                oran = .Height / .Width
                .Width = hucre.Width * 0.95
                .Height = .Width * oran
            End If
            
            .Left = hucre.Left + (hucre.Width - .Width) / 2
            .Top = hucre.Top + (hucre.Height - .Height) / 2
        End With
    Next hucre
    
    Application.ScreenUpdating = True
    MsgBox "Para resimleri G sütunundaki orijinal boyutlarında yerleştirildi!", vbInformation
End Sub

 

[mehmetaltin]

Kod kullanarak çoğaltabilir miyim ,makro kullanmayı bilmiyorum..