Страницы: 1
RSS
VBA - построение расписания, Ошибки в текущем коде
 
Друзья, всем привет!
Недавно начал постигать азы VBA, не кидайте, пожалуйста, сильно камнями.
Код у меня не может похвастаться чистотой, да и правильностью работы.

Нужна ваша помощь.


Сама суть: есть 3 столбца на "Лист1". Столбец A - Идентификатор, Столбец B - Дата и время начала смены, Столбец C - Дата и время окончания смены. Нужно построить график присутствия в каждый часовой интервал.

Задача: На втором листе создать график так, чтобы были только уникальные идентификаторы в столбце A, в ячейках справа от них были количества встречающихся значений по часу.

Имеется: Исходная таблица с данными, строка Даты-времени на "Лист2", чтобы понимать в какой интервал каждый идентификатор есть/нет и в каком количестве.

Почему необходимо: Работаю с огромными массивами данных, количество идентификаторов в исходной таблице "Лист1" занимает порядка 200тыс строк, количество столбцов на "Лист2" в разбивке по часам составляет около 2252 столбцов (что эквивалентно 3 месяцам в разбивке по часам). С формулами грузит в районе 4 часов. При работе с выдачей массивов через For - около часа. Хочется максимально ускорить процесс. SQL не обладаю, поэтому пытаюсь через VBA. Изучаю все постепенно.

Что не смог решить сам: почему-то макрос при начале смены в 12:00 вставляет значение в 11:00, хотя явно указано другое.

Файл примера прикрепил. Ничего лишнего. Объем данных оставил минимальным.


Код
Sub Создать_График()

    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim lastRow1 As Long, lastRow2 As Long
    Dim i As Long, j As Long, k As Long
    Dim name As String
    Dim startDateTime As Date, endDateTime As Date
    Dim currentDateTime As Date
    Dim hoursDiff As Integer
    Dim presenceCount As Integer
    Dim nameColumn As Integer
    Dim uniqueNames As Collection

    ' Указываем листы
    Set ws1 = ThisWorkbook.Sheets("Лист1")
    Set ws2 = ThisWorkbook.Sheets("Лист2")

    ' Находим последнюю заполненную строку на Листе1 и Листе2
    lastRow1 = ws1.Cells(ws1.Rows.count, "B").End(xlUp).Row
    lastRow2 = ws2.Cells(ws2.Rows.count, "A").End(xlUp).Row

    ' Находим последний столбец с именами на Листе2
    nameColumn = ws2.Cells(1, ws2.Columns.count).End(xlToLeft).Column

    ' Инициализируем коллекцию для хранения уникальных имен
    Set uniqueNames = New Collection

    ' Проходим по каждой строке на Листе1
    For i = 2 To lastRow1
        ' Получаем имя
        name = ws1.Cells(i, 1).Value

        ' Проверяем, является ли имя уникальным
        On Error Resume Next
        uniqueNames.Add name, CStr(name)
        On Error GoTo 0
    Next i

    ' Добавляем уникальные имена на Лист2
    For i = 1 To uniqueNames.count
        If Application.WorksheetFunction.CountIf(ws2.Range("A:A"), uniqueNames.Item(i)) = 0 Then
            ws2.Cells(lastRow2 + i, 1).Value = uniqueNames.Item(i)
        End If
    Next i

    ' Проходим по каждой строке в Листе2 (каждому уникальному имени)
    For i = 2 To lastRow2 + uniqueNames.count
        ' Получаем имя
        name = ws2.Cells(i, 1).Value

        ' Проходим по каждой строке на Листе1
        For j = 2 To lastRow1
            ' Проверяем, совпадает ли имя на Листе1 с текущим именем на Листе2
            If ws1.Cells(j, 1).Value = name Then
                ' Получаем дату и время начала и окончания работы
                startDateTime = ws1.Cells(j, 2).Value
                endDateTime = ws1.Cells(j, 3).Value

                ' Проходим по каждому часу в промежутке между началом и окончанием работы
                For k = 0 To DateDiff("h", startDateTime, endDateTime)
                    currentDateTime = DateAdd("h", k, startDateTime)

                    ' Подсчитываем присутствие в каждом часе
                    If currentDateTime >= ws2.Cells(1, 2).Value And currentDateTime <= ws2.Cells(1, ws2.Columns.count).End(xlToLeft).Value Then
                        hoursDiff = DateDiff("h", ws2.Cells(1, 2).Value, currentDateTime) + 1
                        presenceCount = ws2.Cells(i, hoursDiff).Value
                        ws2.Cells(i, hoursDiff).Value = presenceCount + 1
                    End If
                Next k
            End If
        Next j
    Next i

    ' Форматируем данные на Листе2
    ws2.Rows(1).AutoFilter
    ws2.Columns.AutoFit

End Sub
 
Здравствуйте  Вы ошибаетесь, что явно указано другое. Разберем 1 итерацию
Код
hoursDiff = DateDiff("h", ws2.Cells(1, 2).Value, currentDateTime) + 1
presenceCount = ws2.Cells(i, hoursDiff).Value
ws2.Cells(i, hoursDiff).Value = presenceCount + 1

Первая строка функция  DateDiff кол-во часов между 0 часов и 12 часов  возвращает 12. Вы добавляете 1 получается 13. Третья строка вы вставляете в ячейку 13 столбца. В 13 столбце у вас стоят часы 11:00. Так что куда вы указали туда и ставиться.

Изменено: Евгений Смирнов - 05.02.2024 21:35:35
 
В добавлении уникальных на Лист2 строка не корректно будет добавлять данные в некоторых случаях
(по примеру первые два уже есть на Листе 2, третье добавиться через 2 пустые строки)
Код
ws2.Cells(lastRow2 + i, 1).Value = uniqueNames.Item(i)

можно заменить например на

Код
ws2.Cells(lastRow2 + 1, 1).Value = uniqueNames.Item(i)
lastRow2 = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row

Нужно ещё определиться с подсчётом в каждом часе, а то у вас из-за ">= AND <=" оба хвоста входят, хотя присутствие 6 часов, а на Лист 2 идет 7 часов.

На вскидку добавил работу не с листами, а с массивами (при больших объемах быстрее на лист записать сразу массив, а не записывать в каждую ячейку.
Можно ещё ускорить по желанию, гуру если что поправят :)
Изменено: Александр Макаров - 06.02.2024 00:37:14
 
Wadee, добрый вечер.
Попробуйте ещё такой вариант. Ошибки смещения даты нет.
Думаю по времени будет гораздо быстрее. 😉
Изменено: asesja - 08.02.2024 00:11:51
 
Цитата
написал:
Здравствуйте  Вы ошибаетесь, что явно указано другое.
Цитата
написал:
Можно ещё ускорить по желанию, гуру если что поправят
Цитата
написал:
Wadee , добрый вечер.
Хочу высказать каждому из вас огромное спасибо. Вы как нельзя лучше объяснили и продемонстрировали мастерство. Моя скромная благодарность не знает границ.  Спасибо каждому из вас еще раз. Сейчас сяду и буду штудировать код символ за символом, чтобы точно разобраться и понять.
Низкий поклон!
 
Wadee, Все бы ничего, но вот название темы подкачало. В нем должна быть отражена суть задачи. Предложите новое название - поменяем
Согласие есть продукт при полном непротивлении сторон.

Контакты, благодарности
 
Цитата
написал:
В нем должна быть отражена суть задачи.
VBA - построение расписания. Ошибки в текущем коде

Извиняюсь за неясность, проглядел. Тяжелый день был при создании темы.
Страницы: 1
Наверх