Public Sub Extract()
    
    On Error Resume Next
    
    Set myOlApp = Outlook.Application
    Set mynamespace = myOlApp.GetNamespace("mapi")
  
    Dim strRowData As String
    Dim strDelimiter As String
    Dim myDestFolder As Outlook.Folder
    Dim olRecip As Outlook.Recipient
    Dim ShareInbox As Outlook.MAPIFolder
    Dim SubFolder As Object
    Dim j As Integer
    Dim m As String
    Dim InputF As String
    Dim OutputP As String
    Dim ProdMail As String
    
    Dim oXLApp As Object, oXLwb As Object, oXLws As Object
    
    Dim lRow As Long
    
    On Error Resume Next
    Set oXLApp = GetObject(, "Excel.Application")
    
    '~~> If not found then create new instance
    If Err.Number <> 0 Then
        Set oXLApp = CreateObject("Excel.Application")
    End If
    Err.Clear
    On Error GoTo 0
    
    '~~> Open the relevant file
    Set oXLwb = oXLApp.Workbooks.Open("C:\ETest.xlsx")
           
    'Extract Mailbox and subfolder details from a sheet named as "Folder Details"
    
    Set oXLws = oXLwb.Sheets("Folder Details")
           
    ProdMail = oXLws.Range("B1")
    InputFolder = oXLws.Range("B2")
    OutputFolder = oXLws.Range("B3")
       
       
    strRowData = ""
    
    ' Code to extract emails from specific subfolder within shared folder and copy the data across excel spreadsheet.
    
    Set olRecip = mynamespace.CreateRecipient(ProdMail)
       
    Set ShareInbox = mynamespace.GetSharedDefaultFolder(olRecip, olFolderInbox) ' Look into Inbox emails
    Set SubFolder = ShareInbox.Folders(InputFolder) 'Change this line to specify folder
    Set myDestFolder = ShareInbox.Folders(OutputFolder)
      
      If ShareInbox.Folders(InputFolder) = 0 Then
       MsgBox "New Apps folder doesn't exist"
       Exit Sub
    End If
    
    If ShareInbox.Folders(OutputFolder) = 0 Then
       MsgBox "Completed Apps folder doesn't exist"
       Exit Sub
    End If
    
      
    Set oXLws = oXLwb.Sheets("Output")
    
    oXLwb.worksheets("Output").Cells.Clear
          
    lRow = 2
     
    oXLws.Range("A1").Value = "Name"
    oXLws.Range("B1").Value = "ID"
    oXLws.Range("C1").Value = "Address"
    oXLws.Range("D1").Value = "Phone Number"
   
    
   If SubFolder.Items.Count = 0 Then
   
      MsgBox "There are no emails in the " & InputFolder & " folder", , "No Emails"
      
      Exit Sub
    
   End If
    
    For I = 1 To SubFolder.Items.Count
    
        messageArray = ""
        strRowData = ""
    
        Set myitem = SubFolder.Items(1)
        
        msgtext = Trim(myitem.Body)
        
       'search for specific text
    
        delimtedMessage = Replace(Trim(msgtext), "A1", "###")
               
        delimtedMessage = Replace(Trim(delimtedMessage), "B1", "###")
                
        delimtedMessage = Replace(Trim(delimtedMessage), "C1", "###")
                
        delimtedMessage = Replace(delimtedMessage, "D1", "###")
                
        messageArray = Split(delimtedMessage, "###")
        
          With oXLws
           
                .Range("A" & lRow).Value = messageArray(1)
                .Range("B" & lRow).Value = messageArray(2)
                .Range("C" & lRow).Value = messageArray(3)
                .Range("D" & lRow).Value = messageArray(4)
                             
           End With
            
            lRow = lRow + 1
                       
        myitem.Move myDestFolder
  
    Next I
        
        oXLwb.Save
    
        oXLwb.Close (True)
        
        MsgBox "The Macro ran successfully."
                  
    End Sub