Вроде готово, погонял по всем параметрам, работает Правда, сильно завязано на содержание листа "График" и очищает перед новой заливкой... не быстро Если понадобятся комментарии в коде, пишите. Вычисление количества дней переехало в модуль листа 1 и выполняется по простому клику по ячейке с датой начала отпуска.
Вроде готово, погонял по всем параметрам, работает Правда, сильно завязано на содержание листа "График" и очищает перед новой заливкой... не быстро Если понадобятся комментарии в коде, пишите. Вычисление количества дней переехало в модуль листа 1 и выполняется по простому клику по ячейке с датой начала отпуска.StoTisteg
Большущее Вам СПАСИБО. Вы очень сильно мне помогли. Вот только осталась одна проблема. При подсчете дней отпуска у рабочего 6 почему-то в марте проставляет ОТ на весь месяц, а не на оставшиеся дни. Как это исправить?
Большущее Вам СПАСИБО. Вы очень сильно мне помогли. Вот только осталась одна проблема. При подсчете дней отпуска у рабочего 6 почему-то в марте проставляет ОТ на весь месяц, а не на оставшиеся дни. Как это исправить?Jester
Это не надо исправлять, я специально выставил ему 69 дней отпуска для проверки. Можете посчитать вручную, он ешё и апрель захватит. Зато я придумал, как определедять глубину пересчёта автоматом. Ща сделаю...
Это не надо исправлять, я специально выставил ему 69 дней отпуска для проверки. Можете посчитать вручную, он ешё и апрель захватит. Зато я придумал, как определедять глубину пересчёта автоматом. Ща сделаю...StoTisteg
Интуитивно понятный код - это когда интуитивно понятно, что это код.
Проблема не решена. Может в коде проблемы или в моём ДНК еще не разобрался :( код
[vba]
Код
Public ТекМесяц, НачСтрока, КонСтрока As Integer 'Просматриваемый на первом листе месяц и строки, с которых он начинается и кончается. Глобальные, т. к. их вызывают две подпрограммы
Sub todaym() ' Сегодня Макрос Range("Q1") = DateSerial(Year(Date), Month(Date), 1) End Sub Sub NextM() ' Следующий Макрос Range("Q1") = DateAdd("m", 1, Range("Q1")) End Sub Sub Beform() ' Месяц до Макрос Range("Q1") = DateAdd("m", -1, Range("Q1")) End Sub
Sub ПокраскаГрафика()
Dim Имя As Integer 'Номер строки, в которую будем писать ОТ Dim i, k As Integer 'Служебные счётчики Dim ПервДень, ПослДень 'Дни начала и окончания отпуска в просматриваемом месяце Dim Назад As Boolean 'Признак того, что надо смотреть ещё на месяц назад
ТекМесяц = Month(Cells(1, 17).Value) 'Определяем текущий месяц Call НужныеСтроки 'Вызов подпрограммы определения строк начала и конца месяца в листе отпуска If НачСтрока <> 0 Then 'Если он там вообше есть With ThisWorkbook.Worksheets(ActiveSheet.Index - 1) 'Указываем, что до End With работаем с первым листом, чтобы не громоздить чудовищных конструкций For i = НачСтрока To КонСтрока 'Просматриваем текущий месяц Имя = 0 'Обнуляем рабочую строку On Error Resume Next 'Игнор ошибки "Не найдено" Имя = Columns(5).Find(What:=.Cells(i, 3).Value).Row + 2 'Ищем строку с таким же именем и спускаемся на две ниже ПервДень = Day(.Cells(i, 6).Value) + 8 'День начала берём с первого листа ПослДень = Day(.Cells(i, 6).Value) + .Cells(i, 7).Value + 7 'А день окончания в текущем месяце вычисляем прибавлением длительности If Имя <> 0 Then Range(Cells(Имя, ПервДень), Cells(Имя, ПослДень)).Value = "ОТ" 'Заполняем ОТ-ами вычисленный интервал Next i End With End If j = 1 Do While ТекМесяц > 1 'Идём назад до января, чтобы не морочиться с определением, нужно ли это ТекМесяц = Month(Cells(1, 17).Value) - j Call НужныеСтроки If НачСтрока <> 0 Then With ThisWorkbook.Worksheets(ActiveSheet.Index - 1) For i = НачСтрока To КонСтрока k = Val(.Cells(i, 5).Value) - DateDiff("d", .Cells(i, 6).Value, DateAdd("m", j, DateAdd("d", 1 - Day(.Cells(i, 6).Value), .Cells(i, 6).Value))) 'вычисляем попавший на текущий месяц остаток отпуска If k > 0 Then 'Если он положителен Имя = 0 On Error Resume Next Имя = Columns(5).Find(What:=.Cells(i, 3).Value).Row + 2 If Имя <> 0 Then ПервДень = 8 '... то в текущем месяце отпуск начинается с первого числа ПослДень = k + 8 'и заканчивается через k дней Do While Val(Cells(6, ПослДень).Value) < 1 'Если выехали за календарь ПослДень = ПослДень - 1 'Уменьшаем конечную дату, пока не вернёмся в рамки Loop Range(Cells(Имя, ПервДень), Cells(Имя, ПослДень)).Value = "ОТ" End If End If Next i End With End If j = j + 1 Loop
End Sub
Sub НужныеСтроки()
Есть = True With ThisWorkbook.Worksheets(ActiveSheet.Index - 1) НачСтрока = 0 'Обнуляем начальную строку, чтобы проверять наличие месяца For i = 23 To .UsedRange.Rows.Count 'Перебираем все строки до конца листа On Error Resume Next 'игнорируем вопли VBA ЭТО НЕ ДАТА!!!111 If Month(.Cells(i, 6).Value) = ТекМесяц Then 'Если найден искомый месяц НачСтрока = i 'объявляем строку с ним начальной Exit For 'и покидаем цикл End If Next i If НачСтрока <> 0 Then 'если месяц вообще есть КонСтрока = НачСтрока 'предполагаем, что он кончается на том же, на ком начался For i = НачСтрока + 1 To .UsedRange.Rows.Count 'и идём просматривать лист вниз On Error Resume Next If Month(.Cells(i, 6).Value) <> ТекМесяц Then 'Если следующая строка уже не из того месяца КонСтрока = i - 1 'возвращаем указатель конца вверх Exit For End If Next i End If End With
End Sub
Sub NameMasters() Dim nm_tr As Boolean, nm nm_tr = False
For Each nm In ActiveWorkbook.Names 'проверим наличие именного диапазона "Мастера" If nm.Name Like "Мастера" Then nm_tr = True: Exit For Next nm If nm_exist Then 'если есть именной диапазон "Мастера" изменим согласно выделенного диапазона ActiveWorkbook.Names("Мастера").RefersToR1C1 = Selection Else 'если нет - создадим ActiveWorkbook.Names.ADD Name:="Мастера", RefersToR1C1:=Selection End If End Sub
T = Timer Set iSH = Sheets("График") Set iSHist = Sheets("Черновик") EndR = iSH.Cells(Rows.Count, 7).End(xlUp).Row 'последняя заполненная строка График EndRist = iSHist.Cells(Rows.Count, 6).End(xlUp).Row 'последняя заполненная строка Черновик
iNm() = Range("Мастера") 'получим в массив все ФИО мастеров из именного диапазона iNmGr() = iSH.Range("AS1:AS" & EndR).Value 'получим в массив все значения из столбца AS листа График
For i = 1 To UBound(iNm, 1) 'перебираем ФИО мастеров For ii = 1 To UBound(iNmGr, 1) 'перебираем значения столбца AS If iNm(i, 1) = iNmGr(ii, 1) Then 'ищем совпадение ФИО мастера из Черновика с ФИО из График iSH.Range("I" & ii & ":" & "AM" & ii).Value = _ iSHist.Range("D" & Range("Мастера").Row + i - 1 & ":" & "AH" & Range("Мастера").Row + i - 1).Value End If 'на всякий случай предупредим очень долгосрочную работу макроса. Если будет выполнять более 10 сек - остановим макрос If Timer - T > 10 Then MsgBox "Время работы макроса превысило 10 сек. Принудительная остановка!": GoTo Стоп Next ii
'на всякий случай предупредим очень долгосрочную работу макроса. Если будет выполнять более 10 сек - остановим макрос If Timer - T > 10 Then MsgBox "Время работы макроса превысило 10 сек. Принудительная остановка!": GoTo Стоп Next i Стоп: 'Application.Calculation = xlAutomatic 'вкл пересчет формул Application.ScreenUpdating = True 'вкл обновление экрана
End Sub
Sub NewColumn() 'вставим строки для нового Рабочего в низ таблицы Application.ScreenUpdating = False 'откл обновление экрана Dim iClmn% iClmn = Cells(Rows.Count, 7).End(xlUp).Row + 3 'последняя заполненная строка Range("B8:AS1100").Copy Range("B" & iClmn).Select ActiveSheet.Paste Range("B" & iClmn & ":G" & iClmn + 2 & ",I" & iClmn & ":AM" & iClmn + 2 & ",AO" & iClmn & ":AS" & iClmn + 2).ClearContents Rows(iClmn & ":" & iClmn + 2).RowHeight = Rows(8).RowHeight Range("B" & iClmn).Select '================================== 'зададим новую обасть печать ActiveSheet.PageSetup.PrintArea = Range("B4:AO" & iClmn + 2).Address '================================== Application.ScreenUpdating = True 'вкл обновление экрана End Sub
[/vba]
[moder]Код нужно обтягивать кнопкой # (Даже если он под спойлером). [/moder]
Проблема не решена. Может в коде проблемы или в моём ДНК еще не разобрался :( код
[vba]
Код
Public ТекМесяц, НачСтрока, КонСтрока As Integer 'Просматриваемый на первом листе месяц и строки, с которых он начинается и кончается. Глобальные, т. к. их вызывают две подпрограммы
Sub todaym() ' Сегодня Макрос Range("Q1") = DateSerial(Year(Date), Month(Date), 1) End Sub Sub NextM() ' Следующий Макрос Range("Q1") = DateAdd("m", 1, Range("Q1")) End Sub Sub Beform() ' Месяц до Макрос Range("Q1") = DateAdd("m", -1, Range("Q1")) End Sub
Sub ПокраскаГрафика()
Dim Имя As Integer 'Номер строки, в которую будем писать ОТ Dim i, k As Integer 'Служебные счётчики Dim ПервДень, ПослДень 'Дни начала и окончания отпуска в просматриваемом месяце Dim Назад As Boolean 'Признак того, что надо смотреть ещё на месяц назад
ТекМесяц = Month(Cells(1, 17).Value) 'Определяем текущий месяц Call НужныеСтроки 'Вызов подпрограммы определения строк начала и конца месяца в листе отпуска If НачСтрока <> 0 Then 'Если он там вообше есть With ThisWorkbook.Worksheets(ActiveSheet.Index - 1) 'Указываем, что до End With работаем с первым листом, чтобы не громоздить чудовищных конструкций For i = НачСтрока To КонСтрока 'Просматриваем текущий месяц Имя = 0 'Обнуляем рабочую строку On Error Resume Next 'Игнор ошибки "Не найдено" Имя = Columns(5).Find(What:=.Cells(i, 3).Value).Row + 2 'Ищем строку с таким же именем и спускаемся на две ниже ПервДень = Day(.Cells(i, 6).Value) + 8 'День начала берём с первого листа ПослДень = Day(.Cells(i, 6).Value) + .Cells(i, 7).Value + 7 'А день окончания в текущем месяце вычисляем прибавлением длительности If Имя <> 0 Then Range(Cells(Имя, ПервДень), Cells(Имя, ПослДень)).Value = "ОТ" 'Заполняем ОТ-ами вычисленный интервал Next i End With End If j = 1 Do While ТекМесяц > 1 'Идём назад до января, чтобы не морочиться с определением, нужно ли это ТекМесяц = Month(Cells(1, 17).Value) - j Call НужныеСтроки If НачСтрока <> 0 Then With ThisWorkbook.Worksheets(ActiveSheet.Index - 1) For i = НачСтрока To КонСтрока k = Val(.Cells(i, 5).Value) - DateDiff("d", .Cells(i, 6).Value, DateAdd("m", j, DateAdd("d", 1 - Day(.Cells(i, 6).Value), .Cells(i, 6).Value))) 'вычисляем попавший на текущий месяц остаток отпуска If k > 0 Then 'Если он положителен Имя = 0 On Error Resume Next Имя = Columns(5).Find(What:=.Cells(i, 3).Value).Row + 2 If Имя <> 0 Then ПервДень = 8 '... то в текущем месяце отпуск начинается с первого числа ПослДень = k + 8 'и заканчивается через k дней Do While Val(Cells(6, ПослДень).Value) < 1 'Если выехали за календарь ПослДень = ПослДень - 1 'Уменьшаем конечную дату, пока не вернёмся в рамки Loop Range(Cells(Имя, ПервДень), Cells(Имя, ПослДень)).Value = "ОТ" End If End If Next i End With End If j = j + 1 Loop
End Sub
Sub НужныеСтроки()
Есть = True With ThisWorkbook.Worksheets(ActiveSheet.Index - 1) НачСтрока = 0 'Обнуляем начальную строку, чтобы проверять наличие месяца For i = 23 To .UsedRange.Rows.Count 'Перебираем все строки до конца листа On Error Resume Next 'игнорируем вопли VBA ЭТО НЕ ДАТА!!!111 If Month(.Cells(i, 6).Value) = ТекМесяц Then 'Если найден искомый месяц НачСтрока = i 'объявляем строку с ним начальной Exit For 'и покидаем цикл End If Next i If НачСтрока <> 0 Then 'если месяц вообще есть КонСтрока = НачСтрока 'предполагаем, что он кончается на том же, на ком начался For i = НачСтрока + 1 To .UsedRange.Rows.Count 'и идём просматривать лист вниз On Error Resume Next If Month(.Cells(i, 6).Value) <> ТекМесяц Then 'Если следующая строка уже не из того месяца КонСтрока = i - 1 'возвращаем указатель конца вверх Exit For End If Next i End If End With
End Sub
Sub NameMasters() Dim nm_tr As Boolean, nm nm_tr = False
For Each nm In ActiveWorkbook.Names 'проверим наличие именного диапазона "Мастера" If nm.Name Like "Мастера" Then nm_tr = True: Exit For Next nm If nm_exist Then 'если есть именной диапазон "Мастера" изменим согласно выделенного диапазона ActiveWorkbook.Names("Мастера").RefersToR1C1 = Selection Else 'если нет - создадим ActiveWorkbook.Names.ADD Name:="Мастера", RefersToR1C1:=Selection End If End Sub
T = Timer Set iSH = Sheets("График") Set iSHist = Sheets("Черновик") EndR = iSH.Cells(Rows.Count, 7).End(xlUp).Row 'последняя заполненная строка График EndRist = iSHist.Cells(Rows.Count, 6).End(xlUp).Row 'последняя заполненная строка Черновик
iNm() = Range("Мастера") 'получим в массив все ФИО мастеров из именного диапазона iNmGr() = iSH.Range("AS1:AS" & EndR).Value 'получим в массив все значения из столбца AS листа График
For i = 1 To UBound(iNm, 1) 'перебираем ФИО мастеров For ii = 1 To UBound(iNmGr, 1) 'перебираем значения столбца AS If iNm(i, 1) = iNmGr(ii, 1) Then 'ищем совпадение ФИО мастера из Черновика с ФИО из График iSH.Range("I" & ii & ":" & "AM" & ii).Value = _ iSHist.Range("D" & Range("Мастера").Row + i - 1 & ":" & "AH" & Range("Мастера").Row + i - 1).Value End If 'на всякий случай предупредим очень долгосрочную работу макроса. Если будет выполнять более 10 сек - остановим макрос If Timer - T > 10 Then MsgBox "Время работы макроса превысило 10 сек. Принудительная остановка!": GoTo Стоп Next ii
'на всякий случай предупредим очень долгосрочную работу макроса. Если будет выполнять более 10 сек - остановим макрос If Timer - T > 10 Then MsgBox "Время работы макроса превысило 10 сек. Принудительная остановка!": GoTo Стоп Next i Стоп: 'Application.Calculation = xlAutomatic 'вкл пересчет формул Application.ScreenUpdating = True 'вкл обновление экрана
End Sub
Sub NewColumn() 'вставим строки для нового Рабочего в низ таблицы Application.ScreenUpdating = False 'откл обновление экрана Dim iClmn% iClmn = Cells(Rows.Count, 7).End(xlUp).Row + 3 'последняя заполненная строка Range("B8:AS1100").Copy Range("B" & iClmn).Select ActiveSheet.Paste Range("B" & iClmn & ":G" & iClmn + 2 & ",I" & iClmn & ":AM" & iClmn + 2 & ",AO" & iClmn & ":AS" & iClmn + 2).ClearContents Rows(iClmn & ":" & iClmn + 2).RowHeight = Rows(8).RowHeight Range("B" & iClmn).Select '================================== 'зададим новую обасть печать ActiveSheet.PageSetup.PrintArea = Range("B4:AO" & iClmn + 2).Address '================================== Application.ScreenUpdating = True 'вкл обновление экрана End Sub
[/vba]
[moder]Код нужно обтягивать кнопкой # (Даже если он под спойлером). [/moder]Jester
Сообщение отредактировал Manyasha - Понедельник, 29.02.2016, 12:47
Range("Q1:V1").Value = DateAdd("d", 1 - Day(Date), Date) 'Выставляем первое число текущего месяца On Error Resume Next 'игнор ошибки чистильщика (возникает, если нечего чистить) Columns("I:AM").Replace What:="ОТ", Replacement:="", LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False 'Очистка ячеек с ОТ ((с)Макрорекордер, что там лишнее, лень разбираться) Call ПокраскаГрафика 'Вызов подпрограммы с покраской
End Sub Sub NextM()
Range("Q1:V1").Value = DateAdd("m", 1, Cells(1, 17).Value) 'Увеличиваем дату на месяц On Error Resume Next Columns("I:AM").Replace What:="ОТ", Replacement:="", LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False Call ПокраскаГрафика
End Sub Sub Beform()
Range("Q1:V1").Value = DateAdd("m", -1, Cells(1, 17).Value) 'Уменьшаем дату на месяц Columns("I:AM").Replace What:="ОТ", Replacement:="", LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False Call ПокраскаГрафика
End Sub
[/vba] сделали [vba]
Код
Sub todaym() ' Сегодня Макрос Range("Q1") = DateSerial(Year(Date), Month(Date), 1) End Sub Sub NextM() ' Следующий Макрос Range("Q1") = DateAdd("m", 1, Range("Q1")) End Sub Sub Beform() ' Месяц до Макрос Range("Q1") = DateAdd("m", -1, Range("Q1")) End Sub
[/vba] "лишние" строки [vba]
Код
Columns("I:AM").Replace What:="ОТ", Replacement:="", LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False 'Очистка ячеек с ОТ ((с)Макрорекордер, что там лишнее, лень разбираться) Call ПокраскаГрафика 'Вызов подпрограммы с покраской
[/vba] как раз и делали то, что Вам нужно.
И да, то, что Вы из [vba]
Код
Sub todaym()
Range("Q1:V1").Value = DateAdd("d", 1 - Day(Date), Date) 'Выставляем первое число текущего месяца On Error Resume Next 'игнор ошибки чистильщика (возникает, если нечего чистить) Columns("I:AM").Replace What:="ОТ", Replacement:="", LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False 'Очистка ячеек с ОТ ((с)Макрорекордер, что там лишнее, лень разбираться) Call ПокраскаГрафика 'Вызов подпрограммы с покраской
End Sub Sub NextM()
Range("Q1:V1").Value = DateAdd("m", 1, Cells(1, 17).Value) 'Увеличиваем дату на месяц On Error Resume Next Columns("I:AM").Replace What:="ОТ", Replacement:="", LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False Call ПокраскаГрафика
End Sub Sub Beform()
Range("Q1:V1").Value = DateAdd("m", -1, Cells(1, 17).Value) 'Уменьшаем дату на месяц Columns("I:AM").Replace What:="ОТ", Replacement:="", LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False Call ПокраскаГрафика
End Sub
[/vba] сделали [vba]
Код
Sub todaym() ' Сегодня Макрос Range("Q1") = DateSerial(Year(Date), Month(Date), 1) End Sub Sub NextM() ' Следующий Макрос Range("Q1") = DateAdd("m", 1, Range("Q1")) End Sub Sub Beform() ' Месяц до Макрос Range("Q1") = DateAdd("m", -1, Range("Q1")) End Sub
[/vba] "лишние" строки [vba]
Код
Columns("I:AM").Replace What:="ОТ", Replacement:="", LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False 'Очистка ячеек с ОТ ((с)Макрорекордер, что там лишнее, лень разбираться) Call ПокраскаГрафика 'Вызов подпрограммы с покраской
[/vba] как раз и делали то, что Вам нужно.StoTisteg
Интуитивно понятный код - это когда интуитивно понятно, что это код.
Я соберу все решения в кучу и выложу в готовых решениях готовый шаблон. И конечно же с благодарностью всем кто мне помог в этом. Думаю такая вещь очень многим пригодится
Я соберу все решения в кучу и выложу в готовых решениях готовый шаблон. И конечно же с благодарностью всем кто мне помог в этом. Думаю такая вещь очень многим пригодитсяJester
Сообщение отредактировал Jester - Понедельник, 29.02.2016, 23:02