VBA - 通过循环填充单元格时检查重复项答案

【问题标题】：VBA - check for duplicates while filling cells through a loopVBA - 通过循环填充单元格时检查重复项
【发布时间】：2016-12-12 04:22:52
【问题描述】：

我正在编写一个 VBA 代码，它通过定义的矩阵大小并在其限制内随机填充单元格。

我从 stackoverflow 上的用户那里得到了代码，但在测试后我意识到它不适合避免重复填充，例如在填充 5 个单元格时，我只能看到 4 个单元格被填充，这意味着随机填充作用于先前填充的单元格。

这是我正在使用的代码：

Dim lRandom As Long
Dim sCells As String
Dim sRandom As String
Dim rMolecules As Range
Dim i As Integer, j As Integer
Dim lArea As Long


lArea = 400 '20x20
'Populate string of cells that make up the container so they can be chosen at random
For i = 1 To 20
    For j = 1 To 20
        sCells = sCells & "|" & Cells(i, j).Address
    Next j
Next i
sCells = sCells & "|"

'Color the molecules at random
For i = 1 To WorksheetFunction.Min(5, lArea)
    Randomize
    lRandom = Int(Rnd() * 400) + 1
    sRandom = Split(sCells, "|")(lRandom)
    Select Case (i = 1)
        Case True:  Set rMolecules = Range(sRandom)
        Case Else:  Set rMolecules = Union(rMolecules, Range(Split(sCells, "|")(lRandom)))
    End Select
    sCells = Replace(sCells, "|" & sRandom & "|", "|")
    lArea = lArea - 1
Next i

rMolecules.Interior.ColorIndex = 5

使用同样完美的代码，我可以插入什么以及在哪里执行此操作，以便代码检查单元格之前是否已经填充了字符串或颜色？

我觉得我正在寻找的这段代码应该就在之前

rMolecules.Interior.ColorIndex = 5

但我不知道该输入什么。

编辑从 cmets 我意识到我应该更具体。我正在尝试用蓝色（.ColorIndex = 5）随机填充单元格，但我首先需要检查的是随机化是否没有标记单元格两次，例如在这种情况下，如果我想标记5 个不同的单元格，由于重复，它仅标记其中 4 个，因此仅用蓝色填充 4 个单元格。我需要避免这种情况，让它选择另一个单元格来标记/填充。

感谢您的帮助。

【问题讨论】：

除了你的主要问题，你应该从循环中删除Randomize，甚至从整个函数中删除。它只需要使用一次——最好是在打开工作簿时使用。如果您在循环中使用Randomize - 您将从一组 256 个值中获取随机值 - 这是一个奇怪的错误，自 VBA 开始以来就一直存在。
我必须说我不完全理解你想要做什么。您正在寻找一种用随机颜色填充单元格但又不想重复颜色的方法？
@Spurious：我正在寻找一种用某种颜色（在本例中为蓝色）随机填充单元格的方法，但在填充单元格之前，它应该检查随机化是否未标记一个单元格两次 - 这意味着当我用 .ColorIndex = 5 填充它时，它不会再次填充同一个单元格
如果.ColorIndex = 5 之前没有填写，它会是真的吗？ IE。在此之前，您的工作表是否有不同的内部颜色，或者这仅用于将单元格标记为随机？
如果颜色已经是蓝色应该怎么办？

标签： vba excel loops duplicates

【解决方案1】：

将您使用的单元格保留在 Collection 中，并在填充随机单元格时将其删除：

Sub FillRandomCells(targetRange As Range, numberOfCells As Long)

    ' populate collection of unique cells
    Dim c As Range
    Dim targetCells As New Collection

    ' make sure arguments make sense
    If numberOfCells > targetRange.Cells.Count Then
        Err.Raise vbObjectError, "FillRandomCells()", _
                "Number of cells to be changed can not exceed number of cells in range"
    End If

    For Each c In targetRange.Cells
        targetCells.Add c
    Next

    ' now pick random 5
    Dim i As Long, randomIndex As Long
    Dim upperbound As Long
    Dim lowerbound As Long

    For i = 1 To numberOfCells
        lowerbound = 1                 ' collections start with 1
        upperbound = targetCells.Count ' changes as we are removing cells we used

        randomIndex = Int((upperbound - lowerbound + 1) * Rnd + lowerbound)
        Set c = targetCells(randomIndex)
        targetCells.Remove randomIndex ' remove so we don't use it again!

        c.Interior.Color = 5           ' do what you need to do here
    Next

End Sub

Sub testFillRandomCells()
    FillRandomCells ActiveSheet.[a1:t20], 5
    FillRandomCells ActiveSheet.[b25:f30], 3
End Sub

编辑：更改为使目标范围和更改单元格的数量可配置为函数的参数。还添加了错误检查（总是这样做！）。

【讨论】：

谢谢@Logan Reed，我会试试这个，虽然 Spurious 的代码也有效。谢谢两位的代码，你很有帮助。非常感谢。
@vbmolec Spurious 的代码肯定会起作用。我的解决方案避免了完全检查重复项的需要，这稍微更有效。您还应该在每次循环迭代时避免 Splitting 那个数组——它非常低效（在开始时执行一次并保留为变量）。
我想我会用你的代码替换我现有的代码，它看起来确实更有效率。不过我有一个问题：我需要使其动态化 - 用户选择存储在 2 个变量中的尺寸，并且代码只能在这 2 个数字内工作：100x100 或 15x15 等等，我如何让您的代码更加动态在这一行： For Each c In ActiveSheet.[a1:t20].Cells ' 20x20 range ?
@vbmolec 您可以在其中使用任何Range 对象 - 只需确保要更改的单元格数小于目标范围内的单元格数。请参阅示例中的更新。
这段代码比我的好，我删除了我的，因为它不是一个超级干净的解决方案。

【解决方案2】：

为什么不构建一个随机数列表并放入 Scripting.Dictionary，可以使用 Dictionary 的 Exist 方法来检测重复项，循环直到你有足够的数量，然后你可以输入你的着色代码确信你有一个唯一的列表.

【讨论】：

我不确定为什么每个人都求助于Scripting.Dictionary，因为它与标准Collection 之间的唯一区别是您无法检索密钥（在输入值之后）。其他一切都可以使用标准 VBA 方法（不是内置的，但您可以自己编写）来实现。