Добрый день, Уважаемые Я VBA - дуб/дерево/баобаб, сделайте пжлста. Собственно сабж в названии. Так же есть лист желаемый результат Более расширено: Есть 2 листа. "график" - название листа неизменно (столбец "В" - ФИО, строки "4,51,98" - ДАТЫ) "хотелки" - название листа неизменно (столбец "А" - ФИО, столбец "В" - "дата С", столбец "С" - "Дата ДО"). НА одно ФИО может как быть 10 строчек с датой так и вообще не быть. На листе "График" необходимо поставить 1, Согласно ФИО и ДАТА с листа "хотелки", напротив ФИО и ДАТА на листе "ГРАФИК". На листе "график" есть 3 диапазона куда надо ставить 1, по 44 строки в каждом.
Скрытый текст
1.Суть такая изначально работники заполняют свои хотелки по отпускам. 2.Нажимается волшебная кнопочка и формируется/визуализируется график. 3.Далее уже в ручном режиме корректируется в зависимости от возможностей. 4.И в конечном итоге формируется форма Т-7 по отпускам.
P.S. Руклю надо именно вот так вот видеть, с разделением в 3 диапазона.......Я пытался добиться внятного ответа зачем и почему и т.д., но собственно не вышло...
P.S.S Из файла вырезано для примера тонна всего, кому интересно по итогу закину в облако итоговый файл и создам отдельную тему.
Msi2102, Формулами и PQ вопросов нет, примеров куча). Нюанс в названии темы VBA нужно) и именно единички ) Формы запретил рукль менять и сейчас эти "Единички приходится руками ставить" :С
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
Wild.Godlike написал: Не верно заполнен Баранов в периоде с январь-апрель.
почему? потому что я скорректировал данные по нему...
Цитата
Wild.Godlike написал: А диапазоны Май-Август и Сентябрь-Декабрь вообще пустые.
я же написал, что сделал только для одной таблицы.... если сильно не заморачиваться, то можно просто скопировать и чуть-чуть изменить код для двух таблиц ниже. а если таблицы часто изменяются в размерах (количество сотрудников), то лучше подумать об оптимизации кода
Sub aaa()
Application.ScreenUpdating = False
Application.Calculation = xlManual
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
For n = 52 To 95
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 126
If ActiveSheet.Cells(51, k).Value >= Sheets("Хотелки").Cells(c.row, 2).Value _
And ActiveSheet.Cells(51, 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
For n = 99 To 142
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 125
If ActiveSheet.Cells(98, k).Value >= Sheets("Хотелки").Cells(c.row, 2).Value _
And ActiveSheet.Cells(98, 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
Application.ScreenUpdating = True
Application.Calculation = xlAutomatic
End Sub
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
evgeniygeo, Ну в целом да, но зачем, когда нужно раз в год) работает и ладно.....ещё это дурацкое 29 февраля, думать что с ним делать и как.....
Msi2102, Очень сильное колдунство на массивах. Благодарствую. работает вообще очень быстро) экран моргнул- всё готово) Но вот если чёт надо будет поменять) мне кажется я не справлюсь)