Macro para descargar correos de outlook a excel

Realicemos una siguiente prueba para ver si podemos leer los correos de "CM-IB". Realiza los siguientes pasos:

1. Crea una hoja en excel

2. Pon la siguiente macro en un módulo:

Sub GetEmail_2()
'Por Dante Amor
  Dim olApp As Outlook.Application
  Dim objNS As Outlook.Namespace
  Dim olFolder As Outlook.MAPIFolder
  Dim fldr As Outlook.Folder, fldr2 As Outlook.Folder
  Dim msg As Outlook.MailItem
  Dim myItems As Outlook.Items
  Dim nombre As String
  Dim j As Long
  '
  Application.ScreenUpdating = False
  Cells.ClearContents
  '
  Set olApp = Outlook.Application
  Set objNS = olApp.GetNamespace("MAPI")
  '
  For Each fldr In objNS.Folders
    nombre = fldr.Name
    If InStr(1, nombre, "CM-IB") Then
      Set olFolder = objNS.Folders(nombre)
      j = 2
      For Each fldr2 In olFolder.Folders
        Range("B" & j).Value = fldr2.Name
        j = j + 1
      Next
      Exit For
    End If
  Next
End Sub

3. Entra al menú de VBA, Herramientas, Referencias y activa la referencia:

Microsoft Outlook nn.0 Object Library

Nota: nn es la versión de tu office, en mi ejemplo yo tengo la 12.0

Y presiona Aceptar.

4. Ejecuta la macro

5. Dime el resultado que aparece en tu hoja.

Hola buenas noches. Como resultado me trae los nombres de cada carpeta en una lista.

- No mencionaste qué información quieres de cada correo.

- Tampoco mencionaste si quieres el correo que está en la carpeta, por ejemplo 2020, o los correos que están dentro de las subcarpetas. ¿Cuántos niveles de subcarpetas tienes?

- Dependiendo del número de correos en cada carpeta, aumentará el tiempo de proceso de la macro.

Realiza otra prueba. Con la siguiente macro obtendrás los correos de cada carpeta, una hoja por cada carpeta, con los datos: email y asunto.

Sub GetEmail_2()
'Por Dante Amor
  Dim olApp As Outlook.Application
  Dim objNS As Outlook.Namespace
  Dim olFolder As Outlook.MAPIFolder
  Dim fldr As Outlook.Folder, fldr2 As Outlook.Folder
  Dim msg As Outlook.MailItem
  Dim myItems As Outlook.Items
  Dim nombre As String
  Dim j As Long, n As Long
  '
  Application.ScreenUpdating = False
  Cells.ClearContents
  '
  Set olApp = Outlook.Application
  Set objNS = olApp.GetNamespace("MAPI")
  '
  For Each fldr In objNS.Folders
    nombre = fldr.Name
    If InStr(1, nombre, "Amor") Then
      Set olFolder = objNS.Folders(nombre)
      For Each fldr2 In olFolder.Folders
        Sheets.Add after:=Sheets(Sheets.Count)
        Range("A1").Value = fldr2.Name
        j = 2
        Set myItems = fldr2.Items
        On Error Resume Next
        For n = 1 To fldr2.Items.Count
          Range("A" & j).Value = myItems(n).SenderName
          Range("B" & j).Value = myItems(n).Subject
          j = j + 1
        Next
      Next
      Exit For
    End If
  Next
End Sub

Cambia en la macro "Amor" (lo utilizo para mis pruebas) por tu carpeta "CM-IB"

Listo, con esto ya me carga en cada hoja el nombre y asunto de los correos. Como mencioné en la descripción del problema necesitaría descargar los correos contenidos en unas carpetas específicas (Bandeja de entrada y las que se nombran con años), estas carpetas pueden contener subcarpetas (hasta 2 niveles). En concreto necesito los correos allí contenidos (contenido completo del correo).