VBA - Set up a 2D array in VBA with random cells filled with color

问题

I need to set up a 2D array and randomly fill a certain amount of cells in it with color, as if the array is a container and the cells are molecules. After that I need to perform actions on them. The code I tried was:

Sub Insert_Molecules()

Dim Molecules() As Integer

Dim m As Integer, n As Integer
Dim i As Integer, j As Integer

m = 10
n = 10

ReDim Molecules(1 To m, 1 To n) As Integer
For i = 1 To m
For j = 1 To n
Cells(i, j).Interior.Color = RGB(255, 0, 0)
Next j
Next i

End Sub

But what I figured out is that in that case, even if I don't set up an array, it would fill the whole range with color. But I need to fill them randomly within the array - I tried the Rnd function but I don't really know how to use it correctly and it didn't work.

What I tried was

Molecules(i * Rnd, j * Rnd) = Cells(i, j).Interior.Color = RGB(255, 0, 0)

I just think I'm off point here and I'm clueless. I'd appreciate your help.

回答1:

Sub tgr()

    Dim lWidth As Long
    Dim lHeight As Long
    Dim lMolecules As Long
    Dim lArea As Long
    Dim lRandom As Long
    Dim i As Long, j As Long
    Dim sCells As String
    Dim sRandom As String
    Dim rMolecules As Range

    'Get width of container
    lWidth = Int(Application.InputBox("Provide width of container (must be a positive integer)", "Width", 10, Type:=1))
    If lWidth < 1 Then
        MsgBox "Invalid with [" & lWidth & "] provided.  Width must be a positive integer.  Exiting."
        Exit Sub
    End If

    'Get height of container
    lHeight = Int(Application.InputBox("Provide Height of container (must be a positive integer)", "Height", 10, Type:=1))
    If lHeight < 1 Then
        MsgBox "Invalid with [" & lHeight & "] provided.  Height must be a positive integer.  Exiting."
        Exit Sub
    End If

    'Get number of molecules to randomly fill within container
    lMolecules = Int(Application.InputBox("Provide Molecules of container (must be a positive integer)", "Molecules", 10, Type:=1))
    If lMolecules < 1 Then
        MsgBox "Invalid with [" & lMolecules & "] provided.  Molecules must be a positive integer.  Exiting."
        Exit Sub
    End If

    lArea = lWidth * lHeight

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

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

    rMolecules.Interior.ColorIndex = 3

End Sub

回答2:

This will randomly fill between 1 and 100 cells within the first 10 rows and 10 columns of the active sheet in the workbook you are using.

Sub Insert_Molecules()

Dim Molecules() As Integer

Dim m As Integer, n As Integer
Dim i As Integer, j As Integer
Dim NumOfTimes as Integer

Randomize
NumOfTimes  = Int ((100 - 1 + 1) * Rnd + 1)

For i = 1 to NumOfTimes
    Randomize
    Cells(Int ((10 - 1 + 1) * Rnd + 1),Int ((10 - 1 + 1) * Rnd + 1)).Interior.Color = RGB(255,0,0)
Next i   

End Sub

来源：https://stackoverflow.com/questions/38642683/vba-set-up-a-2d-array-in-vba-with-random-cells-filled-with-color