Sub ПолучитьДанныеОтправленныеПисьма()

    Dim olApp As Outlook.Application
    Dim olNs As Outlook.Namespace
    Dim olFolder As Outlook.MAPIFolder
    Dim olMail As Outlook.MailItem
    Dim xlWorksheet As Excel.Worksheet
    Dim iRow As Integer

    'Создать объект приложения Outlook
    Set olApp = New Outlook.Application

    'Создать объект пространства имен
    Set olNs = olApp.GetNamespace("MAPI")

    'Получить папку "Отправленные" в текущем ящике
    Set olFolder = olNs.GetDefaultFolder(olFolderSentMail).Folders("Контроль")

    'Установить активный лист в книге Excel
    Set xlWorksheet = ActiveWorkbook.ActiveSheet

    'Пройти по каждому письму в папке "Отправленные"
    For Each olMail In olFolder.Items
        'Проверить, является ли письмо объектом MailItem и было ли оно отправлено
        If TypeOf olMail Is Outlook.MailItem And olMail.Sent Then
            'Добавить данные в лист Excel
            iRow = xlWorksheet.Cells(xlWorksheet.Rows.Count, 1).End(xlUp).row + 1
            xlWorksheet.Cells(iRow, 1).Value = olMail.Subject
            xlWorksheet.Cells(iRow, 2).Value = olMail.SentOn
            xlWorksheet.Hyperlinks.Add Anchor:=xlWorksheet.Cells(iRow, 3), Address:="outlook:/" & olMail.EntryID, ScreenTip:="Открыть письмо", TextToDisplay:="Открыть письмо"
            xlWorksheet.Hyperlinks.Add Anchor:=xlWorksheet.Cells(iRow, 4), Address:="outlook:/" & olMail.EntryID & "/action=replyall", TextToDisplay:="Ответить всем с вложениями"

        End If

    Next olMail

    'Сохранить и закрыть книгу Excel
    'ActiveWorkbook.Save
    'ActiveWorkbook.Close

    'Освободить объекты из памяти
    Set olMail = Nothing
    Set olFolder = Nothing
    Set olNs = Nothing
    Set olApp = Nothing
    Set xlWorksheet = Nothing

End Sub

Public Q As Integer
Public W As Integer
Public P As Integer
Option Explicit
 
 
 
Sub Подсчет_предыдущих_значений_проба()
 
Dim ArA3, ArB3, ArA4, ArB4
Dim T As Long, W As Long, LastRow3 As Long, LastRow4 As Long
Worksheets("Первая").Select
With Worksheets("Вторая")
  LastRow3 = Cells(Rows.Count, 1).End(xlUp).Row
  ArA3 = Range("B1:B" & LastRow3)
  ArB3 = Range("C1:C" & LastRow3)
  LastRow4 = .Cells(Rows.Count, 2).End(xlUp).Row
  ArA4 = .Range("B1:B" & LastRow4)
  ArB4 = .Range("C1:C" & LastRow4)
  For Q = 2 To LastRow3
    For W = 2 To LastRow4
      P = W
      If ArA3(Q, 1) = ArA4(W, 1) Then
        If ArB3(Q, 1) = ArB4(W, 1) Then
                If PredyduschieZnachenia_проба1 <= PredyduschieZnachenia_проба2 Then
                    Cells(Q, 4) = PredyduschieZnachenia_проба1
                    Cells(Q, 5) = PredyduschieZnachenia_проба2
                    Else: Cells(Q, 6) = "Err"
                End If
            Exit For
        End If
      End If
    Next W
 Next Q
End With
 
 
End Sub
 
 
Function PredyduschieZnachenia_проба1()
 
Dim Rg As Range
Dim RgVal As Integer
Dim a As Variant
Dim i As Integer
Dim cell As Range
Dim Schet As Double
W = P
a = Worksheets("Первая").Cells(Q, 3)
Set Rg = Range(Cells(2, 3), Cells(Q, 3))
RgVal = Rg.Count
 
Dim myColl As Object
Set myColl = New Collection
On Error Resume Next
For Each cell In Rg
    If cell = a Then myColl.Add cell.Value
Next
 
Schet = myColl.Count
PredyduschieZnachenia_проба1 = Schet
Set myColl = New Collection
End Function
 
 
Function PredyduschieZnachenia_проба2()
 
Dim RgW2 As Range
Dim RgVal As Integer
Dim a As Variant
Dim i As Integer
Dim cell As Range
Dim Schet As Double
a = Worksheets("Вторая").Cells(W, 3)
With Worksheets("Вторая")
Set RgW2 = Range(.Cells(2, 3), .Cells(W, 3))
End With
RgVal = RgW2.Count
 
Dim myColl As Object
Set myColl = New Collection
On Error Resume Next
For Each cell In RgW2
    If cell = a And Worksheets("Вторая").Cells(W, 2) = _
    Worksheets("Первая").Cells(Q, 2) Then myColl.Add cell.Value
Next
 
Schet = myColl.Count
PredyduschieZnachenia_проба2 = Schet
Set myColl = New Collection
End Function