Страницы: 1
RSS
VBA: Поставить на листе "график" в трех диапазонах - единичку, согласно ФИО и ДАТА(с/по) на листе "Хотелки"
 
Добрый день, Уважаемые :)
Я VBA - дуб/дерево/баобаб, сделайте пжлста. :oops:
Собственно сабж в названии.
Так же есть лист желаемый результат
Более расширено:
Есть 2 листа.
"график" - название листа неизменно (столбец "В" - ФИО, строки "4,51,98" - ДАТЫ)
"хотелки" - название листа неизменно (столбец "А" - ФИО, столбец "В" - "дата С", столбец "С" - "Дата ДО"). НА одно ФИО может как быть 10 строчек с датой так и вообще не быть.
На листе "График" необходимо поставить 1, Согласно ФИО и ДАТА с листа "хотелки", напротив ФИО и ДАТА на листе "ГРАФИК".
На листе "график" есть 3 диапазона куда надо ставить 1, по 44 строки в каждом.

Скрытый текст
Изменено: Wild.Godlike - 31.10.2022 13:46:38
 
Может ТУТ или ТУТ подойдет информация
Изменено: Msi2102 - 31.10.2022 13:27:15
 
Msi2102, Формулами и PQ вопросов нет, примеров куча).
Нюанс в названии темы VBA нужно) и именно единички )
Формы запретил рукль менять и сейчас эти "Единички приходится руками ставить" :С
 
Wild.Godlike,
а график всегда в таком виде? (по 4 месяца)
 
evgeniygeo, Да
 
Wild.Godlike,
как вариант, на скорую руку (только для одной таблицы)
Код
Sub aaa()
For n = 5 To 48
With Sheets("Хотелки").Range("A1:A50")
  Set c = .Find(ActiveSheet.Cells(n, 2).Value, LookIn:=xlValues)
  If Not c Is Nothing Then
    firstResult = c.Address
    Do
        For k = 4 To 123
            If ActiveSheet.Cells(4, k).Value >= Sheets("Хотелки").Cells(c.Row, 2).Value _
            And ActiveSheet.Cells(4, k).Value <= Sheets("Хотелки").Cells(c.Row, 3).Value Then
                ActiveSheet.Cells(n, k) = 1
            End If
        Next k
      Set c = .FindNext(c)
      If c Is Nothing Then Exit Do
    Loop While c.Address <> firstResult
  End If
End With
Next n
End Sub
Изменено: evgeniygeo - 31.10.2022 14:03:34
 
evgeniygeo,
Что-то непонятное получилось)))
Изменено: Wild.Godlike - 31.10.2022 14:07:19
 
Wild.Godlike,
сорри, скорректировал код через две минуты после публикации.
гляньте еще раз
 
evgeniygeo, Посмотрел.
Не верно заполнен Баранов в периоде с январь-апрель.
А диапазоны Май-Август и Сентябрь-Декабрь вообще пустые.
 
Цитата
Wild.Godlike написал:
Не верно заполнен Баранов в периоде с январь-апрель.
почему? потому что я скорректировал данные по нему...
Цитата
Wild.Godlike написал:
А диапазоны Май-Август и Сентябрь-Декабрь вообще пустые.
я же написал, что сделал только для одной таблицы....
если сильно не заморачиваться, то можно просто скопировать и чуть-чуть изменить код для двух таблиц ниже.
а если таблицы часто изменяются в размерах (количество сотрудников), то лучше подумать об оптимизации кода
Изменено: evgeniygeo - 31.10.2022 14:19:03
 
evgeniygeo, Прошу прощения) глупенький вот и просмотрел) Спасибо большое). сейчас поковыряю для двух таблиц ниже)
Изменено: Wild.Godlike - 31.10.2022 14:21:49
 
По итогу сделал
Добавил ещё в начале

Код
Application.ScreenUpdating = False
Application.Calculation = xlManual

и в конце
Код
Application.ScreenUpdating = True
Application.Calculation = xlAutomatic


Скрытый текст


Летает пушка гонка )
Изменено: Wild.Godlike - 31.10.2022 15:42:54
 
Wild.Godlike,
вообще, можно было бы все-таки сократиться и оптимизироваться, определив диапазоны с помощью "Месяц" в столбце B  :)
Изменено: evgeniygeo - 31.10.2022 16:15:42
 
Вот ещё вариант, будет немного пошустрее
Код
Sub Макрос1()
    Dim arr1 As Variant, arr2 As Variant, arr3(1 To 4) As Variant, rng As Range, n As Integer, m As Integer, i As Byte, j As Byte
    lr1 = Worksheets("Хотелки").Cells(Rows.Count, 1).End(xlUp).Row
    arr1 = Worksheets("Хотелки").Range(Worksheets("Хотелки").Cells(2, 1), Worksheets("Хотелки").Cells(lr1, 3))
    With Worksheets("Желаемый результат")
        lr2 = .Cells(Rows.Count, 2).End(xlUp).Row
        arr2 = .Range(.Cells(4, 2), .Cells(lr2, 2))
        n = 1
        For m = 1 To UBound(arr2)
            If arr2(m, 1) = "ФИО" Then arr3(n) = m: n = n + 1
        Next
        arr3(4) = UBound(arr2)
        For n = 1 To UBound(arr1)
            If Month(CDate(arr1(n, 2))) <= 4 Then
                i = 1
            ElseIf Month(CDate(arr1(n, 2))) <= 8 Then
                i = 2
            Else
                i = 3
            End If
            If Month(CDate(arr1(n, 3))) <= 4 Then
                j = 1
            ElseIf Month(CDate(arr1(n, 3))) <= 8 Then
                j = 2
            Else
                j = 3
            End If
            For m = arr3(i) To arr3(i + 1)
                If arr1(n, 1) = arr2(m, 1) Then
                    If i > 1 Then c = DatePart("y", DateSerial(Year(arr1(n, 2)), (i - 1) * 4 + 1, 1) - 1) Else c = 0
                    d1 = DatePart("y", CDate(arr1(n, 2))) - c
                    If i = j Then
                        d2 = DatePart("y", CDate(arr1(n, 3))) - c
                        If rng Is Nothing Then Set rng = .Range(.Cells(m + 3, d1 + 3), .Cells(m + 3, d2 + 3)) Else Set rng = Union(rng, .Range(.Cells(m + 3, d1 + 3), .Cells(m + 3, d2 + 3)))
                    Else
                        d2 = DatePart("y", DateSerial(Year(arr1(n, 2)), Month(CDate(arr1(n, 3))), 1) - 1) - c
                        If rng Is Nothing Then Set rng = .Range(.Cells(m + 3, d1 + 3), .Cells(m + 3, d2 + 3)) Else Set rng = Union(rng, .Range(.Cells(m + 3, d1 + 3), .Cells(m + 3, d2 + 3)))
                        For m1 = arr3(j) To arr3(j + 1)
                            If arr1(n, 1) = arr2(m1, 1) Then
                                If j > 1 Then c = DatePart("y", DateSerial(Year(arr1(n, 3)), (j - 1) * 4 + 1, 1) - 1) Else c = 0
                                d1 = 1
                                d2 = DatePart("y", CDate(arr1(n, 3))) - c
                                If rng Is Nothing Then Set rng = .Range(.Cells(m1 + 3, d1 + 3), .Cells(m1 + 3, d2 + 3)) Else Set rng = Union(rng, .Range(.Cells(m1 + 3, d1 + 3), .Cells(m1 + 3, d2 + 3)))
                            End If
                        Next
                    End If
                End If
             Next
        Next
        If Not rng Is Nothing Then rng.Value = 1
    End With
End Sub
Изменено: Msi2102 - 31.10.2022 17:42:01
 
evgeniygeo, Ну в целом да, но зачем, когда нужно раз в год) работает и ладно.....ещё это дурацкое 29 февраля, думать что с ним делать и как..... :D

Msi2102,  :oops: Очень сильное колдунство на массивах. Благодарствую. работает вообще очень быстро) экран моргнул- всё готово)
Но вот если чёт надо будет поменять) мне кажется я не справлюсь) :D
Изменено: Wild.Godlike - 31.10.2022 16:49:59
 
Цитата
Wild.Godlike написал:
мне кажется я не справлюсь)
На самом деле это не намного сложнее вариант, чем уevgeniygeo, просто нужно начать разбираться и всё получится :D
 
Собственно как обещал создал тему с готовым файлом >>>
Страницы: 1
Наверх