Работа с выполненными задачами и подзадачами на листе «Проекты»

Переходим к одному из самых сложных, в плане реализации, макросу работы с выполненными задачами и подзадачами на листе «Проекты». Сложность заключается в том, что каждая задача может содержать неограниченное число подзадач, которые выделяли на шаге №2. Тем самым выполненная задача должна перемещаться в архив только после выполнения всех подзадач.

На итог, с помощью макроса, необходимо реализовать ряд задач:

Итоговый вариант макроса выглядит следующим образом:

Автоматизированная работа с выполненными задачами
Макрос работы с выполненными задачами и подзадачами на листе «Проекты»

Для начала добавим функцию появления кнопки «Выполнено» в случае наличия текста в столбце «B» (задача) или «D» (подзадача):

=ЕСЛИ(ИЛИ(B3>0;D3>0);"выполнено";"")

И применим к столбцу «K» условное форматирование, превратив ячейки содержащие тест «выполнено» или «не выполнено» в кнопки.

условное форматирование для кнопок
Условное форматирование столбцов содержащих текст «выполнено» или «не выполнено»

Сам же макрос, с соответствующими комментариями и пояснениями, выглядит следующим образом:

' Выполнено (Не выполнено)
If (Cells(ActiveCell.Row, ActiveCell.Column).Value = "выполнено" Or Cells(ActiveCell.Row, ActiveCell.Column).Value = "не выполнено") And ActiveCell.Column = 11 Then
n_stroki = ActiveCell.Row
zadacha = "Подзадача: "
' статус задачи
vip = "выполнена"
' для наименования кнопки
vip2 = "не выполнено"
' если больше 0 - значит необходимо обновить количество выполненных/не выполненых подзадач
obkol = 0
n_stroki2 = "D" & n_stroki
' если это задача
If Len(Workbooks("planero.xlsm").Worksheets("Проекты").Range(n_stroki2).Value) <= 0 Then
n_stroki2 = "B" & n_stroki
zadacha = "Задача: "
End If
' меняем статус и переменную наименование кнопки
If Cells(ActiveCell.Row, ActiveCell.Column).Value = "не выполнено" Then
vip = "не выполнена"
vip2 = "выполнено"
End If
' выводим сообщение пользователю для подтверждения действия
zapros = MsgBox(zadacha & Chr(10) & Chr(10) & Workbooks("planero.xlsm").Worksheets("Проекты").Range(n_stroki2).Value & Chr(10) & Chr(10) & vip & "?", vbYesNo, "")
If zapros = 6 Then
' если пользователь выбрал что подзадача выполнена
If (vip = "выполнена" And zadacha = "Подзадача: ") Then
With Range("A" & ActiveCell.Row & ":H" & ActiveCell.Row)
.FormatConditions.Delete
.Font.Strikethrough = True
End With
obkol = 1
End If
' если пользователь выбрал что подзадача не выполнена
If (vip = "не выполнена" And zadacha = "Подзадача: ") Then
With Range("A" & ActiveCell.Row & ":H" & ActiveCell.Row)
.FormatConditions.Delete
.Font.Strikethrough = False
.Font.ColorIndex = xlAutomatic
.Font.TintAndShade = 0
End With
' просрочена (условное форматирование)
With Range("E" & ActiveCell.Row)
.FormatConditions.Add Type:=xlCellValue, Operator:=xlLess, Formula1:="='Главная'!$G$7"
.FormatConditions(Range("E" & ActiveCell.Row).FormatConditions.Count).SetFirstPriority
With .FormatConditions(1).Font
.Color = -16383844
.TintAndShade = 0
End With
With .FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 13551615
.TintAndShade = 0
End With
End With
' сегодня (условное форматирование)
With Range("E" & ActiveCell.Row)
.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, Formula1:="='Главная'!$G$7"
.FormatConditions(Range("E" & ActiveCell.Row).FormatConditions.Count).SetFirstPriority
With .FormatConditions(1).Font
.ColorIndex = xlAutomatic
.TintAndShade = 0
End With
With .FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
End With
End With
' застра (условное форматирование)
With Range("E" & ActiveCell.Row)
.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, Formula1:="='Главная'!$H$7"
.FormatConditions(Range("E" & ActiveCell.Row).FormatConditions.Count).SetFirstPriority
With .FormatConditions(1).Font
.ColorIndex = xlAutomatic
.TintAndShade = 0
End With
With .FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent1
.TintAndShade = 0.799981688894314
End With
End With
' без даты
With Range("E" & ActiveCell.Row)
.FormatConditions.Add Type:=xlExpression, Formula1:="=ДЛСТР(СЖПРОБЕЛЫ(E" & ActiveCell.Row & "))=0"
.FormatConditions(Range("E" & ActiveCell.Row).FormatConditions.Count).SetFirstPriority
With .FormatConditions(1).Font
.ColorIndex = xlAutomatic
.TintAndShade = 0
End With
With .FormatConditions(1).Interior
.Pattern = xlNone
.TintAndShade = 0
End With
End With

obkol = 1
End If

' если пользователь выбрал что задача выполнена
If (vip = "выполнена" And zadacha = "Задача: ") Then
i = 1
Do While Len(Range("D" & ActiveCell.Row).Offset(i, 0)) > 0 Or Len(Range("C" & ActiveCell.Row).Offset(i, 0)) > 0
With Range("A" & (ActiveCell.Row + i) & ":H" & (ActiveCell.Row + i))
.FormatConditions.Delete
.Font.Strikethrough = True
End With
' изменяем название кнопки Cells((ActiveCell.Row + i), ActiveCell.Column).FormulaLocal = "=ЕСЛИ(ИЛИ(B" & (ActiveCell.Row + i) & ">0;D" & (ActiveCell.Row + i) & ">0);""" & vip2 & """;" & """"")" i = i + 1 Loop
obkol = 1
End If
End If

' обновляем количество выполненных/не выполненных подзадач в задаче
If obkol = 1 Then
' изменяем название кнопки
Cells(ActiveCell.Row, ActiveCell.Column).FormulaLocal = "=ЕСЛИ(ИЛИ(B" & ActiveCell.Row & ">0;D" & ActiveCell.Row & ">0);""" & vip2 & """;" & """"")"

' сколько строк отступить вверх чтобы найти задачу
i = 0
' опеределяем строку в которой находится задача
Do While Len(Range("B" & ActiveCell.Row).Offset(i, 0)) <= 0
i = i - 1
Loop
' запоминаем номер строки задачи
strzad = ActiveCell.Row + i
' проходим вниз от задачи до тех пор, пока есть подзадачи
i = 1
' сколько задач выполнено?
k = 0
' сколько подгрупп подпункта?
h = 0
Do While Len(Range("D" & strzad).Offset(i, 0)) > 0 Or Len(Range("C" & strzad).Offset(i, 0)) > 0
' если подпункт зачеркнут - считаем его выполненным
If Range("D" & strzad).Offset(i, 0).Font.Strikethrough = True Then k = k + 1
If Len(Range("C" & strzad).Offset(i, 0)) > 0 And Len(Range("D" & strzad).Offset(i, 0)) < 0 Then h = h + 1
i = i + 1
Loop
' Общее количество подзадач
i = i - 1 - h

' если в комментаии задачи записей не было текста
If Len(Range("H" & strzad)) = 0 Then
Range("H" & strzad) = "[Выполнено " & k & " из " & i & " - " & Round(k * 100 / i) & "%]"
Else
str2 = Range("H" & strzad).Value
' если в комментарии задачи не было ранее сделано записи о количестве выполнных подпунктов - добавляем ее в начале
If InStr(1, str2, "[") = 0 Then
Range("H" & strzad) = "[Выполнено " & k & " из " & i & " - " & Round(k * 100 / i) & "%]" & Chr(10) & str2
Else
' находим в комментарии задачи запись о выполненных подзадачах и заменяем ее на обновленные данные
newstr = Mid(str2, InStr(1, str2, "[") + 1, InStr(1, str2, "]") - InStr(1, str2, "[") - 1)
Range("H" & strzad) = Replace(str2, newstr, "Выполнено " & k & " из " & i & " - " & Round(k * 100 / i) & "%")
End If
End If

' если все подзадачи задачи выполнены
If i = k Then
' выводим сообщение пользователю для подтверждения перемещения задачи в архив
zapros = MsgBox("Задача: " & Chr(10) & Chr(10) & Workbooks("planero.xlsm").Worksheets("Проекты").Range("B" & strzad).Value & Chr(10) & Chr(10) & "выполнена. Переместить её в архив?", vbYesNo, "")
If zapros = 6 Then
Cells(strzad, ActiveCell.Column).FormulaLocal = "=ЕСЛИ(ИЛИ(B" & strzad & ">0;D" & strzad & ">0);""не выполнено"";" & """"")"
Cells(ActiveCell.Row, ActiveCell.Column).FormulaLocal = "=ЕСЛИ(ИЛИ(B" & ActiveCell.Row & ">0;D" & ActiveCell.Row & ">0);""" & vip2 & """;" & """"")"
Workbooks("planero.xlsm").Worksheets("Проекты").Rows(strzad & ":" & (strzad + i)).Cut
Workbooks("planero.xlsm").Worksheets("Архив").Select
Workbooks("planero.xlsm").Worksheets("Архив").Rows("3:3").Insert
Workbooks("planero.xlsm").Worksheets("Проекты").Select
Workbooks("planero.xlsm").Worksheets("Проекты").Rows(strzad & ":" & (strzad + i)).Delete Shift:=xlUp
End If
Else
Cells(strzad, ActiveCell.Column).FormulaLocal = "=ЕСЛИ(ИЛИ(B" & strzad & ">0;D" & strzad & ">0);""выполнено"";" & """"")"
End If
End If

Workbooks("planero.xlsm").Worksheets("Проекты").Cells(ActiveCell.Row, ActiveCell.Column - 10).Select
End If

Скачать актуальную версию Планеро.

Поделись с друзьями:
Комментарии 2

© планеро.ru