I have two ranges as showed in this picture.
I'm trying to write a VBA macro that successively selects a single cell in the first range (“B23, F27”) , copies the selected cell's value, then selects a random cell in the second range (“G23, K27”), and pastes the first cell's value into the randomly selected cell in the second range.
This should repeat until every cell from the first range has been copied, or every cell in the second range is filled with a new value. In this example both outcomes are equivalent as both ranges have the same number of cells (25).
The result should be like the second image.
I tried to assign the first range to an array and then pick a random value from this array and paste it to the second range. I also tried to extract unique values from the first range, build a dictionary with it then pick a random cell from the second range and a random value from the dictionary and paste it. Later I tried again using the VBA syntax “with range” and f"or each cell in range" but I can’t just come up with something that actually works. Sometimes the second range is filled by various values, but not as intended.
First example: this one just does not work
Sub fillrange()
Dim empty As Boolean
'This part checks if every cell in the first range as a value in it
For Each Cell In Range("B23", "F27")
If Cell.Value = "" Then
empty = True
End If
Next
'If every cell is filled then
If empty Then
Exit Sub
Else:
With ThisWorkbook.Worksheets("Sheet1)").Range("B23", "F27")
.Cells(Application.WorksheetFunction.RandBetween(1, 25)).Select
.Copy 'the cell select works, but it will copy all range
'This does not work
'For Each Cell In Range("G23", "K27")
'Cells(Application.WorksheetFunction.RandBetween(1, 25)).Select
'.PasteSpecial Paste:=xlPasteValues
'Next
End With
End If
End Sub
Second example: it fills the range but with wrong values
Sub fillrange2()
Dim empty As Boolean
For Each cell In Range("B23", "F27")
If cell.Value = "" Then
empty = True
'This part checks if every cell in the first range as a value in it
Exit For
End If
Next cell
If empty Then
Exit Sub
Else:
Dim ws As Worksheet
Dim lRow As Long, i As Long
Dim col As New Collection, itm As Variant
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
For i = 1 To lRow
On Error Resume Next
col.Add .Range("B23", "F27").Value, CStr(.Range("A" & i).Value)
On Error GoTo 0
Next i
End With
Dim MyAr() As Variant
ReDim MyAr(0 To (col.Count - 1))
For i = 1 To col.Count
MyAr(i - 1) = col.Item(i)
Next
For Each cell In Range("G23", "K27")
cell.Value = Application.WorksheetFunction.RandBetween(LBound(MyAr), UBound(MyAr))
Next
End If
End Sub
Third example: as the second example, it fills the range but with wrong values
Sub fillrange3()
Dim MyAr() As Variant
MyAr = Range("B23", "F27")
For Each cell In Range("G23", "K27")
cell.Value = Application.WorksheetFunction.RandBetween(LBound(MyAr), UBound(MyAr))
Next
End Sub