Function ИНТЕРВАЛДАТ(iTbl As Range, iFIO As String, Optional iMark As String = "")
Dim arr()
Dim arrSpan()
Dim I&, J&, N&, iSpan$
arr = iTbl.Value
ReDim arrSpan(LBound(arr, 2) To UBound(arr, 2), 1 To 2)
For I = LBound(arr, 1) + 1 To UBound(arr, 1)
  If arr(I, 1) Like iFIO Then
    For J = LBound(arr, 2) + 1 To UBound(arr, 2)
      If arr(I, J) = iMark Then
        N = N + 1
        arrSpan(N, 1) = arr(1, J)
        arrSpan(N, 2) = arr(1, J)
        If N > 1 Then
          If arr(1, J) - arrSpan(N - 1, 2) = 1 Then
            N = N - 1
            arrSpan(N, 1) = arrSpan(N, 1)
            arrSpan(N, 2) = arr(1, J)
          End If
        End If
      End If
    Next
    Exit For
  End If
Next
For I = LBound(arrSpan, 1) To N
  If Not IsEmpty(arrSpan(I, 1)) Then
    iSpan = IIf(arrSpan(I, 1) < arrSpan(I, 2), Format(arrSpan(I, 1), "d.mm") & "-" & Format(arrSpan(I, 2), "d.mm"), Format(arrSpan(I, 1), "d.mm"))
    If IsEmpty(ИНТЕРВАЛДАТ) Then
      ИНТЕРВАЛДАТ = iSpan
    Else
      ИНТЕРВАЛДАТ = ИНТЕРВАЛДАТ & ", " & iSpan
    End If
  End If
Next
If IsEmpty(ИНТЕРВАЛДАТ) Then ИНТЕРВАЛДАТ = ""
End Function