Do While Len(Range("B" & nstroka).Value) > 0
    If nnstroka = 0 Then
    MsgBox "0"
        For i = 0 To 12 Step 1
            arr_full(i, nnstroka) = Str(Cells(nstroka, i + 1))
        Next
    ElseIf nnstroka = 1 Then
    MsgBox "1"
        sdist = Str(Range("A" & nstroka).Value)
        sdate = Str(Range("B" & nstroka).Value)
        slogin = Str(Range("H" & nstroka).Value)
        If Not sdist = arr_full(0, nnstroka - 1) And Not sdate = arr_full(1, nnstroka - 1) And Not slogin = arr_full(7, nnstroka - 1) Then
            For i = 0 To 12 Step 1
                arr_full(i, nnstroka) = Cells(nstroka, i + 1)
            Next
        End If
    ElseIf nnstroka > 1 Then
    MsgBox ">1"
        sdist = Str(Range("A" & nstroka).Value)
        sdate = Str(Range("B" & nstroka).Value)
        slogin = Str(Range("H" & nstroka).Value)
        For ii = 0 To nnstroka Step 1
            If sdist = arr_full(0, ii) And sdate = arr_full(1, ii) And slogin = arr_full(7, ii) Then
                GoTo skip1
            Else
            End If
        Next
        For i = 0 To 12 Step 1
            arr_full(i, nnstroka) = Str(Cells(nstroka, i + 1))
        Next
    End If
    nnstroka = nnstroka + 1
skip1:
    nstroka = nstroka + 1
Loop

Dim cert, cert_dir, number As String
cert_dir = "C:\123"
number = "001"
cert = (cert_dir & "\" & "001_скан.pdf")

On Error Resume Next
Set objOutlookApp = GetObject(, "Outlook.Application")
Err.Clear
If objOutlookApp Is Nothing Then
 Set objOutlookApp = CreateObject("Outlook.Application")
End If
objOutlookApp.Session.Logon
Set objMail = objOutlookApp.CreateItem(0)
If Err.number <> 0 Then Set objOutlookApp = Nothing: Set objMail = Nothing: Exit Sub
sSubject = "Важное письмо"

With objMail
 .Subject = sSubject
 .Attachments.Add (cert)
 .Display
End With

Set objOutlookApp = Nothing: Set objMail = Nothing

cert = (cert_dir & "\" & "number*.pdf")
cert = (cert_dir & "\" & number & "*.pdf")
cert = Dir(cert_dir & "\" & "number*.pdf")
cert = Dir(cert_dir & "\" & number & "*.pdf")

Dim procreal as Variant
procreal = (((8 * 8) * 0.05) / 176)

Cells(1,1) = Format(procreal, "Percent")
Cells(1,1) = Format(procreal, "0.00%")

Dim iq, iqq as double
i=0
q=24
qq=12
Do until q>33
  iq=Cells(nstroka, q)
  iqq=Cells(nstroka, qq)
     If iq=1 and iqq>1 then
     i=i+1
     End if
   qq=qq+1
   q=q+1
Loop

Dim sdate as Date
sDate=Cdate(Worksheets("123").Range("V"&nstroka) - тут дата, с которой надо сравнить даты всех других активностей
If Cdate(Range(...))>sdate - это сравнение даты другой активности с присвоенной строкой выше датой

iPath="D:\ДРАФТЫ\" & Workbooks(1).Worksheets("Серт").Range("B" & q).text
ActiveDocument.SaveAs2 iPath & ".docx"

Private Sub TimeYES_Click()
sTime=""
Timetext.Visible=True
Timetext.Enabled=True
sTimeType="Yes"
Timetext.Setfocus
sTime="Срок, устанавливаемый организацией - до " & sdate & " включительно"
End sub

Private sub Timetext_Change()
sdate=TimeText.Value
End sub

Private sub refrash_click()
...
If sTimeType="Yes" Then
MainMsg=MainMsg&vbcrlf&sTime
End if
...
Label=MainMsg
End sub

For ww = LBound(arr) To UBound(arr)
sum = 0
q = 10
Z = Z + 1
Do Until q > 800
If Worksheets("Данные").Range("IP" & q).Text Like arr(ww) Then
If Worksheets("Данные").Range("IW" & q).Value > 43466 Then
sum = sum + 1
End If
End If
q = q + 1
Loop
oTable.Cell(Z,4).Range.InsertAfter sum
Next
MsgBox "Готово"