Рассылка поручений из Excel с помощью макроса

Многие компании используют методологию Scrum - набор принципов, на которых строится процесс разработки, позволяющий в жёстко фиксированные и небольшие по времени итерации, называемые спринтами (sprints), предоставлять конечному пользователю работающее ПО с новыми возможностями, для которых определён наибольший приоритет. ©Wikipedia

И нас эта беда тоже не обошла. В нашей компании в конце спринта проводится ретроспективное совещание (Retrospective meeting), в рамках которого члены команды

• высказывают своё мнение о прошедшем спринте, отвечают на два основных вопроса:
  • что было сделано хорошо в прошедшем спринте?
  • что надо улучшить в следующем?
• выполняют улучшение процесса разработки (решают вопросы и фиксируют удачные решения).

По итогам ретроспектив создается протокол в формате Excel-файла, в котором указываются участники, задачи по улучшению, пути их решения и исполнители. Выглядит это так:

За каждый пункт улучшения команда голосует, и выбираются для решения лучшие из лучших. Сколько голосов от каждого рассчитывается в самом документе, путем указания номера спринта:

Для исполнения используются поручения. Создавать их вручную мы конечно не будем.

Для отправки поручений по этим итогам напрямую из протокола в DIRECTUM был разработан макрос, который может пригодиться каждому.

Текст макроса:

Sub SendAssignment()
'
' SendAssignment Макрос
'
    Const SprintColumnNum = 22 ' Столбец с номером спринта
    Const KAS_DATABASE_NAME = "DIRECTUM" ' Код базы данных
    Const vmSelect = 1
    Const mrOk = 1
    
    Dim dict, sprintNum
    ' Получить данные по исполнителям и срокам
    sprintNum = Cells(1, SprintColumnNum).Text
    Set dict = CreateObject("Scripting.Dictionary")
    sprintNum = GetDataForAssignment(sprintNum, dict)
    
    Dim Connection, RecordSet, ConnectStr, RecordID, RefVid, Index, LogStr, SuccCount, SurName, SurNameArr
    
    Set LP = CreateObject("SBLogon.LoginPoint")
    Set App = LP.GetApplication("systemcode=" + KAS_DATABASE_NAME)
    Set Meeting = App.ReferencesFactory.ReferenceFactory("СВЩ").GetComponent()

    ' Найти совещание по версии 5.4 для текущего спринта в подразделении МКДО в справочнике
    AddWhere = Meeting.AddWhere("MBAnalit.NameAn like '54." + sprintNum + " МКДО%'") 
    Meeting.Open
    If Meeting.RecordCount <> 1 Then
        Set View = Meeting.CreateView(Meeting.MainViewCode)
        View.ViewMode = vmSelect
        View.MainForm.Show
        If View.MainForm.Result <> mrOk Then
            End
        End If
    End If
    Meeting.OpenRecord
    MeetingID = Meeting.Requisites("ИД").AsString
    MeetingCode = Meeting.Requisites("Код").Value
    Set AssignmentRef = App.ReferencesFactory.ReferenceFactory("RRCAssignments").GetComponent

    ' Найти поручения по совещанию
    AddWhereID = AssignmentRef.AddWhere("MBAnalit.Meeting = " + MeetingID) 
    AssignmentRef.ViewName = "Главное"
    AssignmentRef.Open

    Set Environment = AssignmentRef.Environment
    Environment.SetVar "FROM_MEETING", MeetingCode

    ' Добавить новое поручение
    AssignmentRef.Append
    AssignmentRef.Requisites("Текст").Value = "Исполнение решения по совещанию " + Meeting.Requisites("Наименование").AsString                                       
    Set DeliveryListDS = AssignmentRef.DetailDataSet(1) ' Список исполнителей
    Set OtherListDS = AssignmentRef.DetailDataSet(2) ' Список остальных участников, которых надо уведомить
    Set UnitDDS = Meeting.DetailDataSet(2) ' 
    ' Заполнить карточку поручения
    While Not UnitDDS.EOF
        
        SurName = UnitDDS.Requisites("РаботникТ2").DisplayText
        SurNameArr = Split(SurName, " ")
        If dict.Exists(SurNameArr(0)) Then
            SurNameArr = Split(dict(SurNameArr(0)), vbCrLf, 2)
            
            DeliveryListDS.Append
            DeliveryListDS.Requisites("PerformerT").AsString = UnitDDS.Requisites("РаботникТ2").AsString
            DeliveryListDS.Requisites("Дата2Т").Value = SurNameArr(0)
            DeliveryListDS.Requisites("Доп2Т").Value = SurNameArr(1)
            DeliveryListDS.Requisites("TextT").Value = SurNameArr(1)
            DeliveryListDS.Requisites("ДаНетТ").Value = "Нет"
        Else
            OtherListDS.Append
            OtherListDS.Requisites("РаботникТ2").Value = UnitDDS.Requisites("РаботникТ2").AsString
        End If
        UnitDDS.Next
    Wend
    
    ' Показать карточку созданного поручения
    AssignmentRef.Form.ShowModal
    
    AssignmentRef.Close
    AssignmentRef.DelWhere (AddWhereID)
    
    Meeting.CloseRecord
    Meeting.Close
    Meeting.DelWhere (AddWhere)

End Sub

Function GetDataForAssignment(sprintNum, dict)

   ' Параметры документа: из каких столбцов что брать
    Const ExecutorColumnNum = 6 ' Исполнитель
    Const WhatIDoColumnNum = 3 ' Выбранное решение
    Const DeadlineColumnNum = 5 ' Срок
    Dim SprintNumbersRange
    SprintNumbersRange = "A1:A" & Rows.Count ' Столбец с номерами спринтов

    ' Переменные
    Dim mainRange As Range, SurName, rowNum, firstAddress

    With Worksheets(1).Range(SprintNumbersRange)
        .EntireRow.Hidden = False
        Set c = .Find(What:=sprintNum, LookAt:=xlWhole)
        If Not c Is Nothing Then
            firstAddress = c.Address
	     ' Заполнить список исполнителей
            Do
                rowNum = c.Row
                SurName = Cells(rowNum, ExecutorColumnNum).Text
                If SurName <> "" Then
                    ' Если исполнитель уже есть, добавить текст задачи к уже указанному
                    If dict.Exists(SurName) Then
                        dict.Item(SurName) = dict(SurName) & ";" & rowNum
                    ' Если исполнителя ещё нет в списке, добавить
                    Else
                        dict.Add SurName, rowNum
                    End If
                End If
                c.EntireRow.Hidden = True
                Set c = .FindNext(c)
                If c Is Nothing Then
                    GoTo DoneFinding
                End If
            Loop While Not c Is Nothing And c.Address <> firstAddress
        End If
DoneFinding:
        .EntireRow.Hidden = False
    End With

    ' Срок и задачи
    Dim i, j
    For i = 0 To dict.Count - 1
       Key = dict.Keys()(i)
       v = Split(dict(Key), ";")
       If UBound(v) = 0 Then
         txt = Cells(v(0), DeadlineColumnNum) & vbCrLf & Cells(v(0), WhatIDoColumnNum).Text
       Else
         txt = Cells(v(0), DeadlineColumnNum) & vbCrLf
         For j = 0 To UBound(v)
            v(j) = (j + 1) & ". " & Cells(v(j), WhatIDoColumnNum).Text
         Next
         txt = txt & Join(v, vbCrLf)
       End If
    ' Добавить срок первой строкой
       dict(Key) = txt
    Next i
    
    GetDataForAssignment = sprintNum
End Function

В результате работы макроса создается новое поручение и открывается его карточка

Поручение создается на основе совещания. И все участники, которые не будут исполнителями, попадают в наблюдатели – чтобы быть в курсе работ по ретро.

Можно добавить заполнение статусов из поручения в документ, открытие документа или изменить поиск совещания или механизм обработки столбцов документа.