Question

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

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

应重复此操作，直到复制了第一个范围中的每个单元格，或者第二个范围中的每个单元格都填充了新值。在此示例中，两个结果都相等，因为两个范围的单元格数相同（25）。

结果应类似于第二张图片。

我尝试将第一个范围分配给数组，然后从该数组中选择一个随机值并将其粘贴到第二个范围。我还尝试从第一个范围中提取唯一值，用它构建一个字典，然后从第二个范围中选择一个随机单元格，并从字典中选择一个随机值并将其粘贴。后来，我再次尝试使用VBA语法“ with range”和f“或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

也许是这样吗？

annotation

我作弊了，准备在第一个labels中用X1到X25填充G23到K27。

第二个https://www.google.com/bookmarks/mark?op=edit&bkmk={url}&title={title}&annotation={text}&labels={hash_tags}是从B列偏移到G。

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将生成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

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

2 个答案: