Veri aktarımı;

Selam,

filtreleri koda ekleyip işartlerdim bu bu line lar üzerinde oynayabilirsin aşağıdaki linkte objelerin kabul ettiği filtre türleri var. 

 

https://msdn.microsoft.com/VBA/Outlook-VBA/articles/items-restrict-method-outlook

 

Option Explicit

Private lRow As Long, x As Date, oWS As Worksheet

Sub GetFromInbox()
Const olFolderInbox = 6
Dim olApp As Object, olNs As Object
Dim oRootFldr As Object
Dim lCalcMode As Long

Set olApp = CreateObject("Outlook.Application")
Set olNs = olApp.GetNamespace("MAPI")
Set oRootFldr = olNs.GetDefaultFolder(olFolderInbox)  'oldFolderInbox u silip, inbox'da var olan istediğin bi klasörün adını yazabilirsin'

Set myItems = oRootFldr.Items

 Set myRestrictItems = myItems.Restrict("[FirstName] = 'GOKHAN' AND [LastName] = 'DOGAN'")  'ISIM SOYAD FILTERSI'

Set oWS = ActiveSheet

x = Date
lRow = 2
lCalcMode = Application.Calculation
Application.Calculation = xlCalculationManual
'Application.ScreenUpdating = False
GetFromFolder oRootFldr
' Application.ScreenUpdating = True
Application.Calculation = lCalcMode

Set oWS = Nothing
Set oRootFldr = Nothing
Set olNs = Nothing
Set olApp = Nothing
End Sub

Private Sub GetFromFolder(oFldr As Object)
Dim oItem As Object, oSubFldr As Object

For Each oItem In myRestrictItems.Items 'FILTRE'DEN DONEN OBJELER UZERINDE DONGU' 
Range("g1").Value = lRow
If TypeName(oItem) = "MailItem" Then 
With oItem
' If .Subject = "Is Goremezlik Raporu" Then 'bu filtreyi yukarıya taşıyıp orada uygula.'
oWS.Cells(lRow, 1).Value = .SenderName
oWS.Cells(lRow, 2).Value = .to
oWS.Cells(lRow, 3).Value = .cc
oWS.Cells(lRow, 4).Value = .Subject
oWS.Cells(lRow, 5).Value = .ReceivedTime
oWS.Cells(lRow, 6).Value = .body
lRow = lRow + 1
' If lRow = 10 Then Exit Sub
' End If
End With
End If
Next

' Recurse all Subfolders
For Each oSubFldr In oFldr.Folders
GetFromFolder oSubFldr
Next
End Sub

 

 

 

kolay gelsin.