Рассчитать количество смежных часов

Question

У меня есть таблица, содержащая лист под названием «Классы», который содержит начало (L) и время окончания (K) каждого урока, а также продолжительность (J), код класса (A) и студенческое имя (B), которое посещает этот урок.

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

Единственный способ, которым я могу это сделать, - это какой-то цикл, который объединяет имя студента и время начала, а затем сравнивает его с concat ученика и времени окончания. Когда он находит совпадение, он добавляет длительность вместе. Мне нужно, чтобы он вернулся к ученику и в тот день, когда у них было слишком много часов. Я понятия не имею, как это может быть достигнуто в VBA в моем предложении. Есть идеи?

Answer 1

Извините, в этом ответе нет изображений. Новая система для включения изображений, введенных с момента последнего появления ответа, приводит к сбоям или сбоям в моем браузере. Я попробую еще раз завтра. Я пробовал снова без успеха. Я сообщил о проблеме, но сомневаюсь, что я услышу что-либо до понедельника. Возможно, ответ можно использовать без изображений. Кроме того, мой профиль включает адрес электронной почты, позволяющий вам запросить копию изображений, если хотите.

Если вы собираетесь в Google для чего-нибудь, пожалуйста, сделайте это «Учебник по Excel VBA». Если вы ищете код для достижения какой-либо цели, не зная оснований VBA, вы не узнаете код, когда найдете. Здесь мы задаем вопросы, где размещенный код - это почти то, чего хочет этот вопрос, но им не хватает VBA, чтобы сделать даже тривиальное изменение.

Если вы ищете «Учебник по Excel VBA», вы найдете множество на выбор. Попробуйте несколько, а затем заполните тот, который соответствует вашему стилю обучения. Я предпочитаю книги. Я посетил хорошую библиотеку и заимствовал самые перспективные Excel VBA Primers, чтобы попробовать дома. Затем я купил тот, который мне больше всего понравился, как постоянная ссылка. Двенадцать лет спустя я все еще проверяю это снова и снова. Время, затрачиваемое на изучение основ, быстро погасит себя.

Как только вы знаете свои основы, вы готовы приступить к разработке своего макроса. Я создал некоторые демонстрационные данные, которые соответствуют вашему описанию:

Оригинальных данные

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

Чтобы найти непрерывные блоки уроков для учащегося, вам нужны данные, которые должны быть в последовательности ученика-дня. Я ввел «день», как Mon, Tue и т. Д., Который удобен для пользователя, но означает, что при сортировке «Fri» появится «Mon». Макрос обрабатывает каждый день независимо, поэтому он не заботится о последовательности дней. Возможно, это не имеет значения, если аномалия с уроками пятницы доложена до понедельника. Я вернусь к этой проблеме позже.

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

Самый простой способ получить код для сортировки - использовать макрорекордер. Макро-рекордер бесполезен для циклов или if-then-else-endif, но удобен, когда вы не знаете синтаксис для оператора.

Я активировал рабочий лист «Классы», а затем включил макрокорректор. (Инструменты -> Макро -> Запись нового макроса). Я выбрал все ячейки, затем «Данные -> Сортировка», затем задал нужные столбцы. После сортировки я закрыл макрорекордер. Сохраненный код был:

Sub Macro1() 
' 
' Macro1 Macro 
' Macro recorded 10/09/2015 by Tony Dallimore 
' 
    Cells.Select 
    Selection.Sort Key1:=Range("B2"), Order1:=xlAscending, Key2:=Range("G2") _ 
     , Order2:=xlAscending, Key3:=Range("L2"), Order3:=xlAscending, Header:= _ 
     xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ 
     DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:= _ 
     xlSortNormal 
End Sub 

Это синтаксически правильный VBA, но это нехорошо VBA. Макро-рекордер не знает вашей цели; он просто записывает каждое утверждение изолированно. Тем не менее, уборка этого не составляет труда:

With Worksheets("Classes") 

    .Cells.Sort Key1:=.Range("B2"), Order1:=xlAscending, Key2:=.Range("G2") _ 
     , Order2:=xlAscending, Key3:=.Range("L2"), Order3:=xlAscending, Header:= _ 
     xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ 
     DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:= _ 
     xlSortNormal 

    End With 

Вышесказанное является минимальным. Я добавил заявление With, чтобы определить целевой лист; Я удалил Select и поставил период перед Cells и Range, чтобы указать, что они подпадают под действие заявления With. Не беспокойтесь, если вы не знаете, о чем я говорю; как только вы закончите свой учебник, вы это сделаете.

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

Const ColClsStud As String = "B" 
    Const ColClsDay As String = "G" 
    Const ColClsStart As String = "L" 

    With Worksheets("Classes") 

    .Cells.Sort Key1:=.Range(ColClsStud & "2"), Order1:=xlAscending, _ 
       Key2:=.Range(ColClsDay & "2"), Order2:=xlAscending, _ 
       Key3:=.Range(ColClsStart & "2"), Order3:=xlAscending, Header:= _ 
     xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ 
     DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:= _ 
     xlSortNormal 

    End With 

Или мои предпочтения:

Const ColClsStud As Long = 2 
    Const ColClsDay As Long = 7 
    Const ColClsStart As Long = 12 

    With Worksheets("Classes") 

    .Cells.Sort Key1:=.Cells(2, ColClsStud), Order1:=xlAscending, _ 
       Key2:=.Cells(2, ColClsDay), Order2:=xlAscending, _ 
       Key3:=.Cells(2, ColClsStart), Order3:=xlAscending, Header:= _ 
     xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ 
     DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:= _ 
     xlSortNormal 

    End With 

Const (постоянные) высказывания означают, что если движется столбцов, один изменение фиксирует макрос. Мои имена следуют шаблону: строка аббревиатур. Например, ColClsStud - студент-класс-студент.

Теперь мы можем увидеть отсортированный данные:

отсортированные данные

Я только создал данные с понедельника по пятницу, но я считаю, что достаточно для этого ответа. Как упоминалось ранее, «Пт» приходит перед «Мон». Это не имеет значения, поскольку каждый день недели следует рассматривать отдельно. Если это неприемлемо, самым простым решением является написать =FIND(G2,"MonTueWedThuFri") неиспользуемому столбцу строки 2 и скопировать его. Это даст число (Mon-> 1, Tue-> 4, Wed-> 7, Thu-> 10, Fri-> 13), которое можно использовать в сортировке вместо Day. Более элегантные решения доступны, особенно с VBA, если это недостаточно.

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

Помеченные данные

Здесь я цветные блоки более пяти часов. Красный цвет может быть более традиционным, но я нахожу светло-желтый более спокойным. Есть веб-сайты, которые перечисляют все цвета Excel и как их получить, поэтому вы можете переключиться на альтернативный цвет, если вам не нравится мой выбор. Я ввел частично пустые строки, чтобы сообщить потенциально полезные пробелы. Если вам нужно использовать пробел, будет готова строка, которая потребует минимально возможного обновления.

В приведенном ниже макросе указаны константы, определяющие: начало дня, конец дня, размеры зазора и т. Д.

Попробуйте мой макрос на ваши данные. Пройдите через него и изучите, как он распознает большие блоки и пробелы. Согласны ли вы с тем, что используемая техника аналогична используемой человеком?

В макрос включены комментарии, описывающие назначение каждого блока кода, но мало или совсем ничего о заявлениях, используемых для достижения этих целей. Как только вы знаете, что существует инструкция, ее обычно легко найти. Я считаю, что в этом макросе нет ничего, что вам не понадобилось бы в начале учебника, за исключением функций DateAdd и DateDiff. Опять же, легко найти функции, как только вы узнаете их имя. Кроме того, вы можете искать «Функции даты и времени Excel VBA».

Возвращайтесь с вопросами по мере необходимости, но чем больше вы сможете узнать сами, тем быстрее вы будете развиваться.

Я думаю, что обучение программе - это научиться управлять автомобилем. В конце первого урока вы знаете, что НИКОГДА не сможете поворачивать колесо, двигать шестерню, нажимать одну или две из трех педалей, смотреть в три зеркала и одновременно работать с индикатором. Но через месяц вы задаетесь вопросом, что вы нашли так сложно.

Option Explicit 
    Const ColClsCode As Long = 1 
    Const ColClsStud As Long = 2 
    Const ColClsDay As Long = 7 
    Const ColClsDuration As Long = 10 
    Const ColClsEnd As Long = 11 
    Const ColClsStart As Long = 12 
    Const ColClsLast As Long = 12   ' Used for colouring problem rows 

    Const ClrTooLong As Long = &H99FFFF  ' Light yellow = RGB(255,255,153) 

    Const ContinuousMaximum As Long = 300  ' In minutes 
    ' I assume there is a minimum gap between classes to count as a break. 
    Const GapBreakMinimum As Long = 20  ' In minutes 
    ' I assume the is a minimum duration for a class. Gaps smaller than that 
    ' minimum would not be useful, 
    Const GapUsefulMinimum As Long = 30  ' In minutes 
    ' I assume there is a start and end time for the academic day 
    Const TimeDayStart As Date = #9:00:00 AM# 
    Const TimeDayEnd As Date = #3:30:00 PM# 
Sub IdentifyProblemsAndGaps() 

    ' Within worksheet Classes: 
    ' * Colour any sequence of lessons for a student that exceeds the maximum. 
    ' * Insert rows for any gaps that are large enough to be filled with a new lesson. 

    Dim DayCrnt As String 
    Dim RowClsCodeLast As Long 
    Dim RowClsStudCrntFirst As Long 
    Dim RowClsStudLast As Long 
    Dim RowClsCrnt As Long 
    Dim StudentCrnt As String 
    Dim TimeBlockEnd As Date 
    Dim TimeBlockStart As Date 

    ' Application.ScreenUpdating = False ' This speeds the macro but makes debugging more difficult 

    With Worksheets("Classes") 

    ' Remove any colouring remaining from last run of macro. 
    .Cells.Interior.ColorIndex = xlNone 

    ' Sort rows on class code so rows with a blank class code are at the bottom 
    .Cells.Sort Key1:=.Cells(2, ColClsCode), Order1:=xlAscending, Header:=xlYes, _ 
       OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ 
       DataOption1:=xlSortNormal 

    ' Find last used rows in class code and student columns 
    RowClsCodeLast = .Cells(Rows.Count, ColClsCode).End(xlUp).Row 
    RowClsStudLast = .Cells(Rows.Count, ColClsStud).End(xlUp).Row 

    If RowClsStudLast > RowClsCodeLast Then 
     ' There is at least one row with a student name but no class code 
     ' Assume rows without a class code are to report gaps. Such rows 
     ' must be deleted 
     .Rows(RowClsCodeLast + 1 & ":" & RowClsStudLast).Delete 
    End If 

    ' Sort into Student, Day, Start tiem sequence 
    .Cells.Sort Key1:=.Cells(2, ColClsStud), Order1:=xlAscending, _ 
       Key2:=.Cells(2, ColClsDay), Order2:=xlAscending, _ 
       Key3:=.Cells(2, ColClsStart), Order3:=xlAscending, Header:= _ 
     xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ 
     DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:= _ 
     xlSortNormal 

    RowClsCrnt = 2   ' First data row. Assume one header row. 
    TimeBlockStart = 0  ' I assume no lesson can start at midnight 
    TimeBlockEnd = 0 
    StudentCrnt = ""   ' No current student 
    DayCrnt = ""    ' No current day 

    ' The end value for a For-Loop cannot change during a loop. This code inserts 
    ' rows so the end value will change. I have used a Do-Loop instead. 
    Do While True 
     ' When I code a routine, I create test data that covers every scenerio I can 
     ' think of and I code for every scenerio I can think of. I then place 
     ' "Debug.Assert False" at the top of every path through the code. As I 
     ' test the code, I comment out each "Debug.Assert False" reached. If any are 
     ' left at the end of testing, it implies my test data is inadequate or my 
     ' code has a logic error. Either way, it demonstrates that more testing and 
     ' debugging is required 
     'Debug.Assert False 
     If StudentCrnt = .Cells(RowClsCrnt, ColClsStud).Value And _ 
     DayCrnt = .Cells(RowClsCrnt, ColClsDay).Value Then 
     ' Another row for the same student day 
     'Debug.Assert False 
     If DateAdd("n", GapBreakMinimum, TimeBlockEnd) > .Cells(RowClsCrnt, ColClsStart).Value Then 
      ' Current row is part of current block 
      ' Extend current block to include it 
      'Debug.Assert False 
      TimeBlockEnd = .Cells(RowClsCrnt, ColClsEnd).Value 
     Else 
      ' Have gap within day 
      'Check if block just ended is too long; report if it is. 
      'Debug.Assert False 
      Call ReviewBlockJustEndColourIfAppropriate(RowClsStudCrntFirst, RowClsCrnt - 1, _ 
                TimeBlockStart, TimeBlockEnd) 
      ' Check if gap is useful; report if it is. 
      Call ReviewGapFillIfAppropriate(RowClsCrnt, TimeBlockEnd, _ 
              .Cells(RowClsCrnt, ColClsStart).Value, _ 
              StudentCrnt, DayCrnt) 
      ' Start new block 
      TimeBlockStart = .Cells(RowClsCrnt, ColClsStart).Value 
      TimeBlockEnd = .Cells(RowClsCrnt, ColClsEnd).Value 
      RowClsStudCrntFirst = RowClsCrnt 
     End If 
     Else 
     ' New student or new day or first row 
     If StudentCrnt <> "" Then 
      'Check if block just ended is too long; report if it is. 
      'Debug.Assert False 
      Call ReviewBlockJustEndColourIfAppropriate(RowClsStudCrntFirst, RowClsCrnt - 1, _ 
                TimeBlockStart, TimeBlockEnd) 
      ' Check if gap between last class and end of day is useful; report if it is. 
      Call ReviewGapFillIfAppropriate(RowClsCrnt, TimeBlockEnd, _ 
              TimeDayEnd, _ 
              StudentCrnt, DayCrnt) 
     End If 
     ' Start new block 
     StudentCrnt = .Cells(RowClsCrnt, ColClsStud).Value 
     If StudentCrnt = "" Then 
      ' End of data 
      Exit Do 
     End If 
     DayCrnt = .Cells(RowClsCrnt, ColClsDay).Value 
     TimeBlockStart = .Cells(RowClsCrnt, ColClsStart).Value 
     TimeBlockEnd = .Cells(RowClsCrnt, ColClsEnd).Value 
     RowClsStudCrntFirst = RowClsCrnt 
     ' Check if gap between start of day and first class is useful; report if it is. 
     Call ReviewGapFillIfAppropriate(RowClsCrnt, TimeDayStart, _ 
              TimeBlockStart, _ 
              StudentCrnt, DayCrnt) 
     End If 
     RowClsCrnt = RowClsCrnt + 1 
    Loop ' For each data row in Classes 

    End With 

    Application.ScreenUpdating = False 

End Sub 
Sub ReviewBlockJustEndColourIfAppropriate(ByVal RowBlockStart As Long, ByVal RowBlockEnd As Long, _ 
              ByVal TimeBlockStart As Date, ByVal TimeBlockEnd As Date) 

    ' A continuation block of classes for a student has ended. 
    ' Determine is the duration of those classes exceeds the maximum 
    ' Colour classes if their duration exceeds the maximum 

    Dim Duration As Long 

    Duration = DateDiff("n", TimeBlockStart, TimeBlockEnd)  ' Duration in minutes 
    If Duration > ContinuousMaximum Then 
    'Debug.Assert False 
    With Worksheets("Classes") 
     .Range(.Cells(RowBlockStart, 1), _ 
      .Cells(RowBlockEnd, ColClsLast)).Interior.Color = ClrTooLong 
    End With 
    End If 

End Sub 
Sub ReviewGapFillIfAppropriate(ByRef RowClsCrnt As Long, _ 
           ByVal TimeGapStart As Date, ByVal TimeGapEnd As Date, _ 
           ByVal StudentCrnt As String, ByVal DayCrnt As String) 

    ' There may be a gap above the current row. 
    ' Determine if there is a gap and if it is big enough to be useful. 
    ' If there is a useful gap, insert a row reporting the gap. 

    Dim Duration As Long 

    Duration = DateDiff("n", TimeGapStart, TimeGapEnd) ' Duration in minutes 
    If Duration >= GapUsefulMinimum Then 
    ' Have a useful gap. Insert row 
    'Debug.Assert False 
    With Worksheets("Classes") 
     .Rows(RowClsCrnt).Insert 
     .Rows(RowClsCrnt).Interior.ColorIndex = xlNone  ' Ensure colour nor copied from previous row 
     .Cells(RowClsCrnt, ColClsStud).Value = StudentCrnt 
     .Cells(RowClsCrnt, ColClsDay).Value = DayCrnt 
     .Cells(RowClsCrnt, ColClsDuration).Value = Duration 
    End With 
    RowClsCrnt = RowClsCrnt + 1  ' Advance to what was current row 
    End If 

End Sub