My reply seems to have got lost, so let's try again. Processing the sub folders is simple enough. It just requires them to be added to a collection and then process the collection e.g. as follows. I have separated the message processing from the folder processing to make it easier to follow.
Option Explicit
Sub subject2excel()
Dim cFolders As Collection
Dim olFolder As Outlook.Folder
Dim subFolder As Folder
Dim olNS As Outlook.NameSpace
Dim xlApp As Object
Dim xlWB As Object
Dim i As Long
Dim j As Long
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Set xlApp = CreateObject("Excel.Application")
End If
On Error GoTo 0
xlApp.Visible = True
Set xlWB = xlApp.Workbooks.Add
'Set Headings
With xlWB.Sheets(1)
.Range("A" & 1).Value = "Sender"
.Range("B" & 1).Value = "Location"
.Range("C" & 1).Value = "LOB"
.Range("D" & 1).Value = "Date"
.Range("E" & 1).Value = "Shift End Time"
.Range("F" & 1).Value = "Requested Leave Time"
.Range("G" & 1).Value = "Paid/Unpaid"
End With
'Fill sheet
Set cFolders = New Collection
Set olNS = GetNamespace("MAPI")
cFolders.Add olNS.PickFolder
Do While cFolders.Count > 0
Set olFolder = cFolders(1)
cFolders.Remove 1
ProcessFolder olFolder, xlWB
For Each subFolder In olFolder.folders
cFolders.Add subFolder
Next subFolder
Loop
xlWB.Sheets(1).UsedRange.Columns.Autofit
lbl_Exit:
Set olFolder = Nothing
Set subFolder = Nothing
Set xlApp = Nothing
Set xlWB = Nothing
Exit Sub
err_Handler:
GoTo lbl_Exit
End Sub
Sub ProcessFolder(iFolder As Folder, xlWB As Object)
Dim i As Long
Dim olItem As Outlook.MailItem
Dim vSubject As Variant
Dim NextRow As Long
For i = 1 To iFolder.Items.Count
NextRow = xlWB.Sheets(1).Range("A" & xlWB.Sheets(1).Rows.Count).End(-4162).Row + 1
Set olItem = iFolder.Items(i)
If InStr(1, olItem.Subject, "|") > 0 Then
vSubject = Split(olItem.Subject, "|")
With xlWB.Sheets(1)
.Range("A" & NextRow).Value = olItem.Sender
.Range("B" & NextRow).Value = vSubject(0)
.Range("C" & NextRow).Value = vSubject(1)
.Range("D" & NextRow).Value = vSubject(2)
.Range("E" & NextRow).Value = Trim(Mid(vSubject(3), InStr(1, vSubject(3), Chr(58)) + 1))
.Range("F" & NextRow).Value = Trim(Mid(vSubject(4), InStr(1, vSubject(4), Chr(58)) + 1))
.Range("F" & NextRow).HorizontalAlignment = -4152 'align right
.Range("G" & NextRow).Value = Replace(Trim(Mid(vSubject(5), _
InStrRev(vSubject(5), Chr(40)) + 1)), Chr(41), "")
End With
End If
Next i
lbl_Exit:
Set olItem = Nothing
Exit Sub
End Sub