从范围内的单元格复制值并将它们粘贴到范围内的随机单元格中

Question

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

Answer 1

Maybe something like this?

Sub test()
Set Rng = Range("G23:K27")
n = 1
totCell = 25
Set oFill = Range("G23")
Set oSource = Range("B23")

For i = 1 To 5
oFill.Value = "X" & n
oFill.AutoFill Destination:=Range(oFill, oFill.Offset(4, 0)), Type:=xlFillSeries
Set oFill = oFill.Offset(0, 1)
n = n + 5
Next i

For i = 1 To 5
Do
RndVal = Int((totCell - 1 + 1) * Rnd + 1)
xVal = "X" & RndVal
Set C = Rng.Find(xVal, lookat:=xlWhole)
If Not C Is Nothing Then
C.Value = oSource.Value
Set oSource = oSource.Offset(1, 0)
check = check + 1
If check = 5 Then Exit Do
End If
Loop
Set oSource = oSource.Offset(-5, 1)
check = 0
Next i
End Sub

I cheat by making a preparation for the range G23 to K27 fill with X1 to X25 in the first for i = 1 to 5 .

The second for i = 1 to 5 is to offset from column B to G.

The Do - Loop is to generate random number between 1 to 25.
If the generated number is found then the found cell has the value from the "source",
if not found, it loop until the generated number is found 5 times (hence also the found cell is fill with 5 different source). Then before the next i, the "source" cell is offset to the next column.

This if I'm not wrong to get what you mean.

Answer 2

Here's another approach, just for a bit of variety.

Sub x()

Dim r1 As Range, r2 As Range, i As Long
Dim r As Long, c As Long

Set r1 = Range("B23").Resize(5, 5) 'define our two ranges
Set r2 = Range("G23").Resize(5, 5)
r2.ClearContents 'clear output range

With WorksheetFunction
    Do Until .Count(r2) = r2.Count 'loop until output range filled
        r = .RandBetween(1, 25) 'random output cell number
        If .CountIf(r2, r1.Cells(i)) = 0 Then 'if not in output range already
            If r2.Cells(r) = vbNullString Then 'if random cell empty
                r2.Cells(r).Value = r1.Cells(i).Value 'transfer value
                i = i + 1
            End If
        End If
    Loop
End With

End Sub