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

Question

如图所示，我有两个范围。

我正在尝试编写一个 VBA 宏，它依次选择第一个范围 (“B23, F27”) 中的单个单元格，复制所选单元格的值，然后在第二个范围（“G23，K27”），并将第一个单元格的值粘贴到第二个范围内随机选择的单元格中。

这应该重复，直到第一个范围内的每个单元格都被复制，或者第二个范围内的每个单元格都填充了一个新值。在此示例中，两个结果是等效的，因为两个范围具有相同数量的单元格 (25)。

结果应该像第二张图片。

我尝试将第一个范围分配给一个数组，然后从该数组中选择一个随机值并将其粘贴到第二个范围。 我还尝试从第一个范围中提取唯一值，用它构建一个字典，然后从第二个范围中选择一个随机单元格，从字典中选择一个随机值并粘贴它。 后来我再次尝试使用 VBA 语法“with range”和 for“or each cell in range”，但我不能只是想出真正有效的东西。有时，第二个范围由各种值填充，但与预期不同。

第一个例子：这个是行不通的

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

第二个例子：它填充了范围但值错误

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

第三个例子：作为第二个例子，它填充了范围但值错误

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

也许是这样的？

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

我通过在第一个for i = 1 to 5 中为范围 G23 到 K27 填充 X1 到 X25 来作弊。

第二个for i = 1 to 5是从B列偏移到G。

Do - Loop 是生成 1 到 25 之间的随机数。
如果找到生成的数字，则找到的单元格具有来自“源”的值，
如果没有找到，它会循环直到找到生成的数字 5 次（因此找到的单元格也填充了 5 个不同的源）。然后在下一个 i 之前，“源”单元格偏移到下一列。

如果我理解你的意思没有错的话。

Answer 2

这是另一种方法，只是为了多样化。

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