我有两个范围,如图所示。
我想写一个VBA宏,连续选择第一个范围("B23,F27")中的一个单元格,复制所选单元格的值,然后选择一个单元格,然后再选择一个单元格。随机的 的单元格("G23,K27"),并将第一个单元格的值粘贴到第二个范围内随机选择的单元格中。
这个过程应该重复进行,直到第一个范围的每个单元格都被复制,或者第二个范围的每个单元格都被新的值填满。在这个例子中,两个结果都是等价的,因为两个范围内的单元格数量相同(25)。
结果应该像第二幅图一样。
我试着把第一个范围分配给一个数组,然后从这个数组中选取一个随机值并粘贴到第二个范围.我还试着从第一个范围中提取唯一的值,用它建立一个字典,然后从第二个范围中随机选取一个单元格,从字典中选取一个随机值并粘贴.后来我又试着使用VBA语法 "与范围 "和f "或范围中的每个单元格",但我不能只是想出一些实际的工作。有时候第二个范围被各种值填满了,但是没有达到预期的效果。
第一个例子:这个例子根本行不通
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
也许像这样?
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
我作弊的准备范围G23到K27填充与X1到X25的第一次 for i = 1 to 5
.
第二个 for i = 1 to 5
是将B列偏移到G列。
该 Do - Loop
是为了生成1到25之间的随机数。如果生成的数字被找到,那么找到的单元格中就会有 "源 "的值,如果没有找到,就会循环,直到生成的数字被找到5次(因此找到的单元格中也会填入5个不同的源)。然后在下一列i之前,"源 "单元格会偏移到下一列。
如果我没有理解错的话,这就是你的意思。
这里还有一种方法,只是为了变通一下。
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