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
