Блог

Поэтому моя проблема в том, что я пытаюсь пропустить ячейки, которые предварительно заполнены данными. Поэтому, если бы я выбрал день недели в своем расписании, у меня там были бы определенные люди, у которых был бы выходной. Моя главная проблема в том, что я пытаюсь пропустить эти конкретные ячейки, в которых есть крестики. Вот код, который я использую, он заполняет ячейки без проблем, он просто не пропускает ячейки, в которых есть крестики. Список, который у меня есть, находится на отдельном листе. надеюсь, приведенный ниже код поможет мне быть очень зеленым и использовать макросы и vba. спасибо за помощь.

 Sub placements()
Dim SrcRange As Range, FillRange As Range
Dim c As Range, r As Long
Dim rng As Range
Dim BlankCells As Range

Set SrcRange = Worksheets("Placements").Range("A2:A8")
Set FillRange = Selection
Set BlankCells = Selection.SpecialCells(xlCellTypeBlanks)
    
    If TypeName(Selection) <> "Range" Then Exit Sub
    Application.ScreenUpdating = False
    On Error Resume Next

    r = SrcRange.Cells.Count
    For Each c In FillRange
        Do
            c.Value = Application.WorksheetFunction.Index(SrcRange, Int((r * Rnd)   1))
        Loop Until WorksheetFunction.Count(FillRange, c.Value, BlankCells) < 2

    Next
 

Конец Суб

изображение графика

изображение списка, используемого для заполнения пустых ячеек

Попробуй это:

 Sub placements()
    
    Dim FillRange As Range
    Dim c As Range, i As Long, arr
    
    'check a range is selected
    If TypeName(Selection) <> "Range" Then
        MsgBox "select a Column first", vbExclamation
        Exit Sub
    End If
    
    'find all blanks in the selection
    On Error Resume Next
    Set FillRange = Selection.SpecialCells(xlCellTypeBlanks)
    On Error GoTo 0
    If FillRange Is Nothing Then
        MsgBox "No blanks selected!", vbExclamation
        Exit Sub
    End If
    
    'get codes and shuffle them
    arr = Application.Transpose(Worksheets("Placements").Range("A2:A8").Value)
    arr = ShuffleArray(arr)  'make a shuffled copy of the array
    
    i = LBound(arr)
    For Each c In FillRange.Cells
        c.Value = arr(i)
        i = i   1         'next value from array
        If i > UBound(arr) Then
            MsgBox "Too many cells"
            Exit For
        End If
    Next c
    
End Sub

'shuffle an array and return the shuffled copy
Function ShuffleArray(arrIn)
    Dim N As Long, J As Long, Temp As Variant, arr()
    Randomize
    'make a copy of the array
    ReDim arr(LBound(arrIn) To UBound(arrIn))
    For N = LBound(arrIn) To UBound(arrIn)
        arr(N) = arrIn(N)
    Next N
    'shuffle the copy
    For N = LBound(arr) To UBound(arr)
        J = CLng(((UBound(arr) - N) * Rnd)   N)
        Temp = arr(N)
        arr(N) = arr(J)
        arr(J) = Temp
    Next N
    ShuffleArray = arr 'return the shuffled copy
End Function