Kod:
Sub RastgeleKopyalaKurallarlaGelismis()
Dim ws As Worksheet
Dim veriAraligi As Range
Dim hedefSutun As String
Dim rastgeleSira As Collection
Dim rastgeleIndex As Integer
Dim sonSatir As Long
Dim kullanilanSatirlar() As Boolean
Dim secilenDeger As Variant
Dim i As Long
Dim gSayisi As Long
Dim sonSutun As Long
Dim sonSutunHarf As String
Dim hedefSatir As Long
Dim eDegeri As Variant
' Aktif çalışma sayfasını al
Set ws = ActiveSheet
' Rastgele seçimler için başlat
Randomize
' D sütunundaki son hücreyi bul
sonSatir = ws.Cells(ws.Rows.Count, "D").End(xlUp).Row
' D3'ten son hücreye kadar olan aralığı belirle
Set veriAraligi = ws.Range("D3:D" & sonSatir)
' Dizileri tanımla
ReDim kullanilanSatirlar(1 To veriAraligi.Cells.Count)
' Son sütunu bul ve bir sağındaki sütunu belirle
sonSutun = ws.Cells(3, ws.Columns.Count).End(xlToLeft).Column
sonSutunHarf = Split(ws.Cells(1, sonSutun + 1).Address, "$")(1)
' Boş bir sütun bulana kadar devam et
For i = 1 To 100
If WorksheetFunction.CountA(ws.Columns(sonSutunHarf)) = 0 Then Exit For
sonSutunHarf = Chr(Asc(sonSutunHarf) + 1)
Next i
hedefSutun = sonSutunHarf
' Rastgele seçilen hücreleri saklamak için bir koleksiyon oluştur
Set rastgeleSira = New Collection
' G sütunundaki veri sayısını belirle
gSayisi = ws.Cells(ws.Rows.Count, "G").End(xlUp).Row - 2
' Rastgele seçimi başlat
Do While rastgeleSira.Count < gSayisi
rastgeleIndex = Int(Rnd * veriAraligi.Cells.Count) + 1
' Daha önce seçilmediyse işlem yap
If Not kullanilanSatirlar(rastgeleIndex) Then
' Seçilen hücre değerini al
secilenDeger = veriAraligi.Cells(rastgeleIndex).Value
' E sütunundaki değeri al
eDegeri = veriAraligi.Cells(rastgeleIndex).Offset(0, 1).Value
' E değerine göre hedef satırı bul
hedefSatir = 0
For i = 3 To gSayisi + 2
If ws.Cells(i, "F").Value <> eDegeri And ws.Cells(i, "G").Value <> eDegeri And ws.Cells(i, hedefSutun).Value = "" Then
hedefSatir = i
Exit For
End If
Next i
' Hedef satır bulunduysa kopyala
If hedefSatir > 0 Then
ws.Cells(hedefSatir, hedefSutun).Value = secilenDeger
rastgeleSira.Add secilenDeger
kullanilanSatirlar(rastgeleIndex) = True ' İşaretleme yaparak tekrar seçilmesini engelle
' Bir alt satıra da yerleştir (EK KONTROL: H sütunu değerine göre)
If hedefSatir + 1 <= gSayisi + 2 Then
If ws.Cells(hedefSatir + 1, "F").Value <> eDegeri And ws.Cells(hedefSatir + 1, "G").Value <> eDegeri And _
ws.Cells(hedefSatir + 1, hedefSutun).Value = "" And _
ws.Cells(hedefSatir + 1, "H").Value = ws.Cells(hedefSatir, "H").Value Then
ws.Cells(hedefSatir + 1, hedefSutun).Value = secilenDeger
rastgeleSira.Add secilenDeger
kullanilanSatirlar(rastgeleIndex) = True ' İşaretleme yaparak tekrar seçilmesini engelle
End If
End If
End If
End If
Loop
' Bir sonraki sütuna geç
hedefSutun = Chr(Asc(hedefSutun) + 1)
End Sub