Всем привет!
Есть макрос, который запускает сначала обновление запросов в PQ, а потом делает рассылку на почту, но вот проблема в том что обновление не успевает выполниться или возможно нужно сохранить файл перед рассылкой
Далее лист лог, на нем если условия выполнены, то срабатывают обновление и рассылка
Есть макрос, который запускает сначала обновление запросов в PQ, а потом делает рассылку на почту, но вот проблема в том что обновление не успевает выполниться или возможно нужно сохранить файл перед рассылкой
Код |
---|
Private Sub Workbook_Open() ' При открытии книги на листе Лог прописывается ФИО пользователя Worksheets("Лог").Cells(lastrow + 2, 5) = Environ("USERNAME") 'Макрос вставляет формулу и тем самым дает активную ячейку, для проверки условия, макроса на листе Лог Sheets("Лог").Select Range("F2").Select ActiveCell.FormulaR1C1 = "=IF(RC[-1]=""PupkinVasia"",TRUE,FALSE)" End Sub |
Далее лист лог, на нем если условия выполнены, то срабатывают обновление и рассылка
Код |
---|
' Проверка если F2=ИСТИНА,выполняются макросы, сам макрос срабатывает от активизации макросом в модуле ЭтаКнига Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Range("F2")) Is Nothing Then If Target = True Then 'Запускаем макрос обновления Call Обновление 'Запускаем макрос рассылки If Format(Now, "hh:mm") > "21:00" Then Рассылка End If End If End Sub |
Код |
---|
Sub Обновление() ActiveWorkbook.RefreshAll End Sub |
Код |
---|
Sub Рассылка() Dim objOutlookApp As Object, objMail As Object Dim lr As Long, lLastR As Long Application.ScreenUpdating = False On Error Resume Next Set objOutlookApp = CreateObject("Outlook.Application") If Err.Number <> 0 Then Set objOutlookApp = Nothing: Set objMail = Nothing: Exit Sub objOutlookApp.Session.Logon lLastR = Cells(Rows.Count, 1).End(xlUp).Row 'определяем последнюю заполненную ячейку в столбце А 'цикл от второй строки(начало данных с адресами) до последней ячейки таблицы For lr = 2 To lLastR Set objMail = objOutlookApp.CreateItem(0) 'создаем новое сообщение 'создаем сообщение With objMail .To = Cells(lr, 1).Value 'адрес получателя .Subject = Cells(lr, 2).Value 'тема сообщения .Body = Cells(lr, 3).Value 'текст сообщения .Attachments.Add Cells(lr, 4).Value .Send 'Display, если необходимо просмотреть сообщение, а не отправлять без просмотра End With Next lr Set objOutlookApp = Nothing: Set objMail = Nothing Application.ScreenUpdating = True End Sub |