Sub Coupon_Alert_Today()
Application.OnTime TimeValue("18:14:00"), "Coupon_Alert_Today"

Private Sub Workbook_Open()
Application.OnTime TimeValue("18:14:00"), "Coupon_Alert_Today"
End Sub

Sub AutoRunMacro()
Application.OnTime TimeValue("10:00:00"), "procedure" 
End Sub 

Sub Уведомления()
Dim xx
    xx = MsgBox("Расчеты произведены?", vbYesNo, "Провекра")
    
    If xx = 7 Then: Exit Sub
    If xx = 6 Then:
     
    Dim nSess       As Object 'NotesSession
    Dim nDir        As Object 'NotesDbDirectory
    Dim nDb         As Object 'NotesDatabase
    Dim nDoc        As Object 'NotesDocument
    Dim nAtt        As Object 'NotesRichTextItem
    Dim vToList     As Variant, vCCList As Variant, vBody As Variant
    Dim sFilPath    As String
    Dim sPwd        As String
    Dim wrbBal      As Workbook
    Dim shtData     As Worksheet
    Dim strName     As Range
    Dim D           As Date
    Dim a As Variant
    Dim c As Variant
    Dim NextCP As Variant
    Dim shtMC As Worksheet
    Dim rngMCCP As Range
 
    Set nSess = CreateObject("Lotus.NotesSession")
     
    sPwd = Application.InputBox("Type your Lotus Notes password!", Type:=2)
    Call nSess.Initialize(sPwd)

    Set wrbBal = ActiveWorkbook
    Set shtData = wrbBal.Worksheets("База данных")
    Set c = shtData.Range("A2:Q2")
    
    vCCList = "bugaga@mail.ru"
    Set strName = shtData.Range("A2")
    D = Date
    
Do Until strName.Value = ""
    Set shtMC = wrbBal.Worksheets("MC")
    Set rngMCCP = shtMC.Range("A2:G2")
    If c.Cells(1, 17) = "К" Then GoTo NextCP
    If c.Cells(1, 19) = "R" Then
        Do Until rngMCCP.Cells(1, 1).Value = ""
              
            If rngMCCP.Cells(1, 1) = c.Cells(1, 1) Then
                If rngMCCP.Cells(1, 2) > 0 Then

                    vToList = c.Cells(1, 14)
                    Set nDir = nSess.GetDbDirectory("")
                    Set nDb = nDir.OpenMailDatabase
                    Set nDoc = nDb.CreateDocument

                    With nDoc
         
                    Set nAtt = .CreateRichTextItem("Body")
                    Call .ReplaceItemValue("Form", "Memo")
                    Call .ReplaceItemValue("Subject", "Notification " & strName & " " & D & "")
         
                    With nAtt
                         .AppendText ("Добрый день!")
                         .AddNewLine
                         .AddNewLine
                         .AppendText ("текст" & Abs(rngMCCP.Cells(1, 2)) & " " & rngMCCP.Cells(1, 6) & " text " & rngMCCP.Cells(1, 7) & "")
                         .AddNewLine
                         .AddNewLine
                         .AppendText ("текст: " & rngMCCP.Cells(1, 3) & "")
                         .AddNewLine
                         .AppendText ("текст: " & rngMCCP.Cells(1, 4) & "")
                          End With
    
                    Call .ReplaceItemValue("CopyTo", vCCList)
                    Call .ReplaceItemValue("PostedDate", Now())
                    Call .Send(False, vToList)
                    End With
                    End If
                    End If
                    Set rngMCCP = rngMCCP.Offset(1)
                    Loop               
    Else:
    Do Until rngMCCP.Cells(1, 1).Value = ""
    If rngMCCP.Cells(1, 1) = c.Cells(1, 1) Then
    If rngMCCP.Cells(1, 2) > 0 Then
    vToList = c.Cells(1, 14)
    Set nDir = nSess.GetDbDirectory("")
    Set nDb = nDir.OpenMailDatabase
    Set nDoc = nDb.CreateDocument

    With nDoc
         
    Set nAtt = .CreateRichTextItem("Body")
    Call .ReplaceItemValue("Form", "Memo")
    Call .ReplaceItemValue("Subject", "Notification " & strName & " " & D & "")
            With nAtt
            .AppendText ("Dear All,")
                .AddNewLine
                .AddNewLine
                                .AppendText ("TEXT " & strName & " text " & Abs(rngMCCP.Cells(1, 2)) & " " & rngMCCP.Cells(1, 6) & " text" &  rngMCCP.Cells(1, 7) & "")
                                .AddNewLine
                                .AddNewLine
                                .AppendText ("TEXT: " & rngMCCP.Cells(1, 3) & "")
                                .AddNewLine
                                .AppendText ("TEXT: " & rngMCCP.Cells(1, 4) & "")

                                End With
    
                                Call .ReplaceItemValue("CopyTo", vCCList)
                                Call .ReplaceItemValue("PostedDate", Now())
                                Call .Send(False, vToList)
         
                            End With
                            End If
                        End If
                        
                      Set rngMCCP = rngMCCP.Offset(1)
                      Loop
    End If   
NextCP:
    Set strName = strName.Offset(1)
    Set c = c.Offset(1)
       
Loop

End Sub

Sub Заполнялка()
Dim wbkX As Workbook 
Dim shtData As Worksheet, shtTmpl As Worksheet, shtVal As Worksheet 
Dim rngOld As Range, rngNew As Range 
Dim rngCode As Range
Dim rngValCode As Range
Dim rngTmplVal As Range
Dim rngValAll As Range
Dim a As Date, d As String
a = Date

Set wbkX = ThisWorkbook
Workbooks.Open Filename:="путь.xlsx"

Set shtData = wbkX.Worksheets("БД контрагентов")
Set shtTmpl = Workbooks("Шаблон_пример").Worksheets("Лист1")
Set shtVal = wbkX.Worksheets("Переоценка")

Set rngOld = shtData.Range("A1:F1")
Set rngNew = shtTmpl.Range("A1:H5")

Set rngCode = shtData.Range("B1:B5")
Set rngValCode = shtVal.Range("F1")
Set rngTmplVal = shtTmpl.Range("A15:H15")
Set rngValAll = shtVal.Range("A:F")

Do Until rngOld.Cells(2, 1).Value = ""

    Workbooks("Шаблон_пример").Worksheets("Лист1").Activate
    rngNew.Cells(1, 2).Value = rngOld.Cells(2, 1).Value
    rngNew.Cells(2, 2).Value = rngOld.Cells(2, 5).Value
    rngNew.Cells(2, 4).Value = rngOld.Cells(2, 6).Value
    rngNew.Cells(4, 3).Value = rngOld.Cells(2, 3).Value
    rngNew.Cells(5, 3).Value = rngOld.Cells(2, 4).Value
    
    d = Range("B1")
       
     ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
        "путь\" & a & "_" & d & ".pdf" _
        , Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
        :=False, OpenAfterPublish:=False
        
    rngNew.Cells(1, 2).Clear
    rngNew.Cells(2, 2).Clear
    rngNew.Cells(2, 4).Clear
    rngNew.Cells(4, 3).Clear
    rngNew.Cells(5, 3).Clear
     
    Set rngOld = rngOld.Offset(1)
    
Loop

ActiveWorkbook.Save
ActiveWorkbook.Close

wbkX.Activate
End Sub