Dim app As Outlook.Application
   Dim fld As Outlook.MAPIFolder

    Set app = New Outlook.Application

    For i = 1 To app.Session.Folders.Item(1).Folders.Count

        Set fld = app.Session.Folders.Item(1).Folders(i)
                
        If "E-MAILS" = UCase(fld.Name) Then
        
           For P = 1 To fld.Folders.Count
           
                Set Myfld = fld.Folders(P)
                     
                If "EXPERTS" = UCase(Myfld.Name) Then
                     J = 1
                     While J <= Myfld.Items.Count
                     

                        If TypeName(Myfld.Items.Item(J)) = "MailItem" Then

                            Dim email As MailItem
                            Set email = Myfld.Items.Item(J)
                   
                         '   If email.UnRead = True Then
                           
                                t = 1
                                While t <= Myfld.Items.Count
                               
                                    If TypeName(Myfld.Items.Item(t)) = "MailItem" Then

                                        Dim CompareEmail As MailItem
                                        Set CompareEmail = Myfld.Items.Item(t)
                                       
                                        If email.Subject = CompareEmail.Subject And email.EntryID <> CompareEmail.EntryID Then
                                       
                                            CompareEmail.Delete
                                            Set Myfld = fld.Folders(P)
                                           
                                        End If
                                        
                                        t = t + 1
                                    End If
                                   
                                Wend
                     
                        '    End If

                        End If
                        
                    J = J + 1
                    Wend

                 
                 End If
            Next

        End If
        
    Next

    Set app = Nothing