Макрос заполняет только одну ячейку, а не заканчивается, когда должен

Question

Я пытаюсь создать подпрограмму / макрос, который, учитывая список актеров с квотой и список мест с доступностью, будет распределять актеров по местам, где они доступны, таким образом, чтобы их квота былавстретил. Я озвучил эту систему на более простом примере, который должен учитывать общие угловые случаи и источники большинства проблем с «разрушителями вселенных» применительно к реальным данным.

Я пытаюсь сделать это, расставив приоритеты в первую очередь этим действующим лицам. которые имеют наименьшее текущее количество распределений, и из них субъекты с самой низкой квотой. Целью этого приоритета является

• предотвратить один Актер, выделенный для всех «ранних» мест, и один Актер, выделенный для всех «поздних» мест, исключительно на основе того, где они появились в оригиналесписок Актеров, и

• запрещают выделение Актеров с низкой Квотой для Места, когда этому Месту уже выделено много других Актеров

Я начну с двух простых списков. В Списке 1 столбец Количество изначально равен нулю и обновляется, когда Актер назначается другому Месту. В Списке 2 доступный столбец - это известная Доступность для каждого Места (первоначально строка имен Актеров) (это в настоящее время вручную и будет автоматизировано отдельно), а столбец Распределение - это растущая строка Актеров, выделенных этому Месту (первоначальнопустой список).

Список 1. находится в диапазоне A1: C6.

Actor Quota Count
AA     3     0
BB     4     0
CC     4     0
DD     4     0
EE     6     0

Список 2 находится в диапазоне A10: A21, D10: E21 (столбцы B и Cсодержат другую информацию о местах).

Place Avail Alloc
 1     AABBDD
 2     AACCEE
 3     CCEE
 4     BBEE
 5     BBEE
 6     AACCDD
 7     AACC
 8     BBEE
 9     BBEE
10     CC
11     AACCDDEE
12     AABBDD

Код, приведенный ниже, - это то, что я разработал до сих пор. Теоретически:

1. , если у Актера с наивысшим приоритетом есть Квота, равная его Счету, ничего не делать (и неявно переходить к следующему Актеру в списке).

2. , если Актер с наивысшим приоритетом, прошедший первый тест, имеет место в столбце «Доступно», увеличьте Счет актера на 1, затем добавьте имя Актора в столбец «Распределение» и удалитеИмя актера из колонки «Доступно». В противном случае ничего не делать (и неявно переходить к следующему действующему лицу в списке).

3. Сортировать список 1 в соответствии с приоритетами, упомянутыми ранее.

4. Перейти к следующему месту, повторите шаги 1, 2, 3.

5. Повторите шаги 1, 2, 3, 4 в общей сложности пять раз (чтобы макрос обрабатывалсамая длинная строка из доступных).

   Sub FakeItUntilYouMakeIt()
   Dim m As Integer, n As Integer, i As Integer, p As Integer
   For m = 1 To 5
       For n = 10 To 21
           For i = 2 To 6
           If Cells(i, 2) > Cells(i, 3) Then
               If InStr(1, Cells(i, 1), Cells(n, 4), 1) <> 0 Then
                   p = Cells(i, 3)
                   Cells(i, 3).Value = p + 1
                   Cells(n, 5).Value = Cells(n, 5) & Cells(i, 1)
                   Cells(n, 4).Replace what:=Cells(i, 1), replacement:=""
                   Range("A1:C6").Select
                   ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
                   ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("C2:C6"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                   ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("B2:B6"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                   With ActiveWorkbook.Worksheets("Sheet1").Sort
                       .SetRange Range("A1:C6")
                       .Header = xlYes
                       .MatchCase = False
                       .Orientation = xlTopToBottom
                       .SortMethod = xlPinYin
                       .Apply
                   End With
           End If
           End If
           Next i
       Next n
   Next m
   End Sub
   

Когда я запускаю подпрограмму / макрос, я получаю лист, показанный на скриншоте ниже. В частности,

• ячейка E10 заполнена бессмысленной комбинацией Актеров, возможно потому, что она добавляет все Распределения в это Место вместо того, где они должны

• Список 1 отсортирован по квоте, сначала по наименьшему значению

• Список 1 заканчивается записями столбца Count, которые ровно на 1 меньше, чем записи столбца Quota

• , если подпрограмма / макрос запускается второй раз, ничего не меняется, за исключением того, что все записи столбца Count увеличиваются на 1 и становятся равными записям столбца Quota

Что является причиной того, что подпрограмма / макрос фиксируется в ячейке E10 и, по-видимому, пытается добавить каждое выделение в это место? Я считаю, что это как-то связано с циклом;возможно, он неправильно обрабатывает исключение, когда субъект с наивысшим приоритетом отсутствует в доступной строке для этого места?

Answer 1

Согласно документации Microsoft о функции InStr , вторым аргументом должна быть искомая строка, а третьим аргументом должна быть искомая строка.

Таким образом, InStr(1, Cells(i, 1), Cells(n, 4), 1) <> 0 должно бытьInStr(1, Cells(n, 4), Cells(i, 1), 1) <> 0

Answer 2

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

Dim i As Long
Dim j As Long
Dim k As Long

For i = 2 To 6
    k = 0
    For j = 10 To 21
        If InStr(1, Cells(j, 4).Value, Cells(i, 1).Value) = 0 Then
            k = k
        Else
            k = k + 1
        End If
    Next j
    Cells(i, 4) = k
Next i

С этим кодом вы получите новый столбец, который будет возвращать текущее количество выделений для одного актера. Это ваш первый приоритет. Остальное зависит от вашей стратегии ... Вы можете просто взять первого участника по количеству распределений (меньше распределений) и распределить по ранним или поздним местам (мне не ясно, что вы считаете ранним или поздним), пока квота не станет 0:

Dim Min As Long
Dim lookupvalue As Variant
Dim Totalrange As Range

Set Totalrange = Worksheets("Sheet1").Range("D2:D6")
Min = Application.WorksheetFunction.Min(Totalrange)
lookupvalue = Application.WorksheetFunction.VLookup(Min, Totalrange, 1, False) + 1

For i = 10 To 21
    If InStr(1, Cells(i, 4).Value, Cells(lookupvalue, 1).Value) = 0 Then
            i = i
        Else
            If Cells(lookupvalue, 2).Value > 0 Then
                Cells(i, 5).Value = Cells(i, 5).Value & Cells(lookupvalue, 1).Value
                Cells(lookupvalue, 2).Value = Cells(lookupvalue, 2).Value - 1
                Cells(lookupvalue, 3).Value = Cells(lookupvalue, 3).Value + 1
            End If
        End If
    Next i

Этот цикл будет размещать актера на месте, пока квота не станет равной 0. Если эта стратегия является вашей, вам просто нужно разместить второй цикл, включающий этот, чтобы проверить всеактеры и инструкция сортировки, когда цикл i закончен, поэтому при поиске значения minimun следующее взаимодействие не будет включать в себя предыдущие элементы, уже размещенные. Этот цикл устанавливает актера DD как тот, который имеет меньшее количество распределений