Страницы: 1
RSS
Экспорт таблицы из outlook в excel
 
Всем привет, подскажите пожалуйста, как можно реализовать подобный макрос:

1. При нажатии кнопки, макрос должен найти в outlook письмо с определенной темой но за сегодняшнее число.
2. Скопировать таблицу из данного письма и вставить в лист из которого я запустил макрос.
 
Руслан Нестеренко,
вариант
 
Код
Sub копирование_табл_из_тела_письма()
    otvet = MsgBox("Выполнить проверку корреспонденции?", vbQuestion + vbYesNoCancel, "Запуск процесса...")
    If Not otvet = vbYes Then Exit Sub
    
    Dim objOutlook As Object, objNameSpace As Object, objFoldersAkk As Object
    Dim objFolder As Object, objMail As Object, oItems As Object
    Dim xDoc As Object
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    On Error Resume Next
    Set objOutlook = GetObject(, "Outlook.Application") 'активируем Outlook
    Err.Clear
    If objOutlook Is Nothing Then Set objOutlook = CreateObject("Outlook.Application") 'если не открыт, то открываем Outlook
    ' проверка на наличие установленного Outlook
    If Err.Number <> 0 Then
        Set objOutlook = Nothing
        Application.ScreenUpdating = True
        MsgBox "Внимание! Проверьте правильность установки Outlook!", vbExclamation
        Exit Sub
    End If
    On Error GoTo 0
    Set objNameSpace = objOutlook.GetNamespace("MAPI") ' объявляем переменную для работы с папками Outlook
    ' обновляем почту в Outlook
    For I = 1 To objNameSpace.SyncObjects.Count
        objNameSpace.SyncObjects.Item(I).Start
    Next
    Application.Wait (Now + TimeValue("0:00:05")) ' пауза в выполнении кода для обновления папок Outlook
    ' определяем для обработки папки в аккаунте Outlook
    
    vib_mail_adr = "test@test.ru" ' аккаунт в Outlook
    
    Set objFoldersAkk = objNameSpace.Folders(vib_mail_adr).Folders
    Set objFolder = objNameSpace.Folders(vib_mail_adr).Folders("Входящие") ' папка в аккаунте
    ' просмотр писем в папке
    Set oItems = objFolder.Items: kol_ma_frm = oItems.Count
    For ma = kol_ma_frm To 1 Step -1
        Set objMail = oItems.Item(ma) ' письмо из папки
        znach_subj = Trim(CStr(objMail.Subject)) ' тема письма
        znach_date = Left(objMail.CreationTime, 10) ' дата письма

        find_subj = "Тест" ' значение темы для поиска
        
        If znach_subj = find_subj and znach_date=cstr(cdate(date)) Then
            kon_y = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count - 1
            ActiveSheet.Range("A" & CStr(kon_y)).Select
            Set xDoc = objMail.GetInspector.WordEditor
            For I = 1 To xDoc.Tables.Count
                Set xTable = xDoc.Tables(I)
                xTable.Range.Copy
                ActiveSheet.Paste
                kon_y = kon_y + xTable.Rows.Count + 1
                ActiveSheet.Range("A" & CStr(kon_y)).Select
            Next
        End If
    Next
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    
    MsgBox "Проверка корреспонденции выполнена.", vbInformation
End Sub
На основе
Цитата
написал:
Руслан Нестеренко,
вариант
P.S.: добавил проверку на дату письма
Изменено: Александр Макаров - 22.08.2022 14:31:10
 
Александр Макаров,
Спасибо большое.  Макрос практически работает. Только один нюанс. При вызове макроса он зависает.
и только после завершения работы outlook через диспетчер задач
он выдаёт ошибку и потом вставляет нужную таблицу.

скажите пожалуйста, как это можно поправить ?
Ошибка

Дебаг
 
Может вам лучше тогда через Power query это всё реализовать?
 
А как это можно сделать ?
Страницы: 1
Наверх