Outlook Macro to gather email data from different subfolders into same worksheet

Hi guys,

This is my first post so please be gentle with me :P

So I have this VBA code for gathering email data which I found on the internet and made some minor adjustments to it to fit my needs. I still have one problem which I have been unable to figure out by myself so I was hoping you guys could help

What the code does:

User chooses which mailbox to gather data from
>New excel workbook is opened
>Email data from main folder is extracted

>New excel workbook is opened
>Email data from first subfolder is extracted

>New excel workbook is opened
>Email data from second subfolder is extrated etc. you get the drill.

What I would like it to do is to gather all the email data into the first workbook and everything on one sheet instead of having it open sometimes 20-30 separate workbooks. How would I need to alter the code in that case?

Sub getSubFolders(objParent As Object, colFolders As Collection)
Dim objFolder As Object

    For Each objFolder In objParent.Folders
        colFolders.Add objParent.Folders(objFolder.Name)
        Call getSubFolders(objFolder, colFolders)
    Next objFolder
    
End Sub
Sub ReportResponses()
   Dim objNS As Outlook.NameSpace
    Dim objFolder As Outlook.Folder
    Dim objTable As Outlook.Table
    Dim objRow As Outlook.Row
    Dim objEX As Excel.Application
    Dim objWB As Excel.Workbook
    Dim objWS As Excel.Worksheet
    Dim intR As Integer
    Dim val()
    Dim colFolders As Collection
    
    Const PR_LAST_VERB_EXECUTION_TIME = "http://schemas.microsoft.com/mapi/proptag/0x10820040"
    Const PR_LAST_VERB_EXECUTED = "http://schemas.microsoft.com/mapi/proptag/0x10810003"
    On Error Resume Next
    
    Set colFolders = New Collection
    Set objNS = Application.GetNamespace("MAPI") 
    Set objFolder = objNS.PickFolder
    colFolders.Add objFolder.Name
    getSubFolders objFolder, colFolders '<- populates a collection of Subfolders, starting with folder selected

    'now you can do for each objFolder loop in your code
    For Each objFolder In colFolders
        
        Set objTable = objFolder.GetTable
        
        With objTable
            .Columns.Add "SenderName"
            .Columns.Add "SenderEmailAddress"
            .Columns.Add "SentOn"
            .Columns.Add PR_LAST_VERB_EXECUTION_TIME
            .Columns.Add PR_LAST_VERB_EXECUTED
            .Columns.Add "Categories"
           
            
        End With
        
        
        If objTable.GetRowCount > 0 Then
            Set objEX = CreateObject("Excel.Application")
            Set objWB = objEX.Workbooks.Add
            Set objWS = objWB.Worksheets(1)
            intR = 2
            Do Until objTable.EndOfTable
                Set objRow = objTable.GetNextRow
                val = objRow.GetValues
                With objWS
                    .Cells(intR, 1).Value = val(7) 'SentOn
                    .Cells(intR, 2).Value = val(2) 'CreationTime
                    ' PR_LAST_VERB_EXECUTION_TIME
                    If IsDate(val(8)) Then
                        .Cells(intR, 3).Value = objRow.UTCToLocalTime(9)
                    End If
                    ' PR_LAST_VERB_EXECUTED
                    .Cells(intR, 4).Value = LastVerbText(CInt(val(9)))
                    .Cells(intR, 5).Value = val(5) ' SenderName
                    .Cells(intR, 6).Value = val(6)
                    .Cells(intR, 7).Value = val(1) ' Subject
                    .Cells(intR, 8).Value = val(10) 'Categories
                    .Cells(intR, 9).Value = objFolder.Name ' Folder
                    
                End With
                intR = intR + 1
            Loop
            With objWS
                .Columns("A:I").EntireColumn.AutoFit
               
                .Cells(1, 1).Value = "Sent"
                .Cells(1, 2).Value = "Received"
                .Cells(1, 3).Value = "Response Date"
                .Cells(1, 4).Value = "Response"
                .Cells(1, 5).Value = "Sender Name"
                .Cells(1, 6).Value = "Sender Address"
                .Cells(1, 7).Value = "Subject"
                .Cells(1, 8).Value = "Categories"
                .Cells(1, 9).Value = "Folder"
                .Range("A1:I1").Font.Bold = True
                .Columns("D").EntireColumn.AutoFit
                .Range("A2").AutoFilter
            End With
            objEX.Visible = True
            objWB.Activate
        End If
    Next objFolder
    
    Set colFolders = Nothing
    Set objTable = Nothing
    Set objRow = Nothing
    Set objEX = Nothing
    Set objWS = Nothing
End Sub

Function LastVerbText(verb As Integer)
    Select Case verb
        Case 102
            LastVerbText = "Reply"
        Case 103
            LastVerbText = "Reply to All"
        Case 104
            LastVerbText = "Forward"
        Case Else
            LastVerbText = ""
    End Select
End Function

Thanks for the help in advance!

Br,
M.A