Also, a speacial mention to Andy Pope whom I followed from other forums for his great help to his fellow members.

The code which he helped in optimising for better performance is below.

 '
 '
 ' Requires reference to Outlook library
 '
Public Sub ListOutlookFolders()
     
    Dim olApp As Outlook.Application
    Dim olNamespace As Outlook.NameSpace
    Dim olFolder As Outlook.MAPIFolder
    Dim rngOutput As Range
    Dim lngCol As Long
    Dim olItem As Outlook.MailItem
     
    Set rngOutput = ActiveSheet.Range("A1")
     
    Set olApp = New Outlook.Application
    Set olNamespace = olApp.GetNamespace("MAPI")
     
    For Each olFolder In olNamespace.Folders
        rngOutput = olFolder.Name
        rngOutput.Offset(0, 1) = olFolder.Description
        Set rngOutput = rngOutput.Offset(1)
       For Each olItem In olFolder.Items
    If olItem.Class = olMail Then
        Set rngOutput = rngOutput.Offset(1)
        With rngOutput
            .Offset(0, 1) = olItem.SenderName ' Sender
            .Offset(0, 2) = olItem.Subject ' Subject
            .Offset(0, 3) = olItem.ReceivedTime ' Received
            .Offset(0, 4) = olItem.ReceivedByName ' Recepient
            .Offset(0, 5) = olItem.UnRead ' Unread?
            .Offset(0, 6) = olItem.ReplyRecipientNames '
            .Offset(0, 7) = olItem.SentOn
        End With
    End If
Next

         
        Set rngOutput = ListFolders(olFolder, 1, rngOutput)
    Next
     
    Set olFolder = Nothing
    Set olNamespace = Nothing
    Set olApp = Nothing
     
End Sub
Function ListFolders(MyFolder As Outlook.MAPIFolder, Level As Integer, Output As Range) As Range
     '
     '
     '
    Dim olFolder As Outlook.MAPIFolder
    Dim olItem As Outlook.MailItem
    Dim lngCol As Long
     
    For Each olFolder In MyFolder.Folders
        lngCol = ((Level - 1) * 8) + 1
        Output.Offset(0, lngCol) = olFolder.Name
        Set Output = Output.Offset(1)
        If olFolder.DefaultItemType = olMailItem Then
    For Each olItem In olFolder.Items
        If olItem.Class = olMail Then
            With Output
                .Offset(0, lngCol + 1) = olItem.SenderName ' Sender
                .Offset(0, lngCol + 2) = olItem.Subject ' Subject
                .Offset(0, lngCol + 3) = olItem.ReceivedTime ' Received
                .Offset(0, lngCol + 4) = olItem.ReceivedByName ' Recepient
                .Offset(0, lngCol + 5) = olItem.UnRead ' Unread?
                .Offset(0, lngCol + 6) = olItem.ReplyRecipientNames '
                .Offset(0, lngCol + 7) = olItem.SentOn
                 
            End With
            Set Output = Output.Offset(1)
        End If
    Next
End If

        If olFolder.Folders.Count > 0 Then
            Set Output = ListFolders(olFolder, Level + 1, Output)
        End If
    Next
    Set ListFolders = Output.Offset(1)
     
End Function
Apparently this code was working perfectly fine for the person who originally posted the question. But for me Im getting an error at this line "Set rngOutput = ActiveSheet.Range("A1")" as Öbject Variable or With block variable not set". Please help me in this reagrds.


Thanks in advance.

P.S. Im a newbie @ VBA coding.