Fastest way to recieve data from outlook

[saykotuna]

Hi everyone i have a problem with recieving emails from outlook. When outlook has more than 1000 mails excel loses too much time to write each cell in loop. I need professional advice that make it simplier.
Public Sub Outlook_Mail_Cek()

'Outlook nesneler

Dim olApp As Outlook.Application
Dim olNameSpace As Outlook.Namespace
Dim olFolder As Outlook.MAPIFolder
Dim olItems As Outlook.Items

Dim FolderNo%

'Excel nesneler
Dim wb As Workbook
Dim ws As Worksheet
Dim SatirNo As Long
Dim c As Integer
Dim n As Integer


n = 2
c = 1


Application.ScreenUpdating = False
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Database")


ws.Cells.Clear


With ws
.Activate

.Range("A1").CurrentRegion.Clear

.Cells(1, 1).Value = "Klasor"
.Cells(1, 2).Value = "Gonderim Zamani"
.Cells(1, 3).Value = "Gonderen Kisi"
.Cells(1, 4).Value = "Alici"
.Cells(1, 5).Value = "CC de Bulunanlar"
.Cells(1, 6).Value = "Konu"
.Cells(1, 7).Value = "Icerik"

With .Range("A1:H1")
.Interior.Color = RGB(222, 222, 222)
.Font.Bold = True
.Font.Size = 11
End With
End With


Set olApp = New Outlook.Application
Set olNameSpace = olApp.GetNamespace("MAPI")


For FolderNo = 1 To 99
On Error Resume Next
Err = 0
Set olFolder = olNameSpace.GetDefaultFolder(FolderNo)

Set olItems = olFolder.Items







For Each Item In olFolder.Items

Cells(n, c) = olFolder
Cells(n, c + 1) = Item.ReceivedTime
Cells(n, c + 2) = Item.SenderName
Cells(n, c + 3) = Item.To
Cells(n, c + 4) = Item.CC
Cells(n, c + 5) = Item.Subject
Cells(n, c + 6) = Item.Body
n = n + 1

Next Item

Set olItems = Nothing
Set olFolder = Nothing
Next FolderNo

Set olNameSpace = Nothing
Set olApp = Nothing



Application.ScreenUpdating = True


End Sub






------
That part kills speed



For Each Item In olFolder.Items

Cells(n, c) = olFolder
Cells(n, c + 1) = Item.ReceivedTime
Cells(n, c + 2) = Item.SenderName
Cells(n, c + 3) = Item.To
Cells(n, c + 4) = Item.CC
Cells(n, c + 5) = Item.Subject
Cells(n, c + 6) = Item.Body
n = n + 1

Next Item

----

Help me please

 

[saykotuna]

Nobody to help?

 

[saykotuna]

up

 

[saykotuna]

I have found a solution for fast reading data but i cannot write to range faster than this. Is there anybody who can help me about that? I need array writing

Public Sub Outlook_Mail_Cek()

'Outlook nesneler

Dim olApp As Outlook.Application
Dim olNameSpace As Outlook.Namespace
Dim olFolder As Outlook.MAPIFolder
Dim olItems As Outlook.Items

Dim FolderNo%

'Excel nesneler
Dim wb As Workbook
Dim ws As Worksheet

Dim n As Integer
Dim vtext1(1 To 500) As Variant
Dim i As Integer
 
n = 1



Application.ScreenUpdating = False
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Database")


ws.Cells.Clear






Set olApp = New Outlook.Application
Set olNameSpace = olApp.GetNamespace("MAPI")


For FolderNo = 6 To 6
On Error Resume Next
Err = 0
Set olFolder = olNameSpace.GetDefaultFolder(FolderNo)

Set olItems = olFolder.Items





For Each Item In olFolder.Items

vtext1(n) = olFolder & "__;__" & Item.ReceivedTime & "__;__" & Item.SenderName & "__;__" & Item.To & "__;__" & Item.CC & "__;__" & Item.Subject & "__;__" & Item.Body

n = n + 1

Next Item










Set olItems = Nothing
Set olFolder = Nothing
Next FolderNo


For i = 1 To UBound(vtext1)

Cells(i, 1).Value = vtext1(i)

Next i


Set olNameSpace = Nothing
Set olApp = Nothing


Application.ScreenUpdating = True


End Sub

That part makes code slower


For i = 1 To UBound(vtext1)

Cells(i, 1).Value = vtext1(i)

Next i

 

[saykotuna]

up