Macro pegar cuerpo email recibido

Macro pegar cuerpo email recibido en una variable

Buenas noches compañeros, no se mucho de excel y necesito su ayuda, estoy haciendo una macro que me copie el cuerpo de un correo y me lo pegue en Excel pero no que me copie todo el cuerpo en una celda si no como viene en el correo por ejemplo si el correo es:

[ATTACH]29920.vB[/ATTACH]

Pegar asi

[ATTACH]29921.vB[/ATTACH]

en varias celdas

Hasta el momento copio todos mis correos en una capeta que cree en la bandeja de entrada llamada "audicase" y luego cuando finaliza la macro me los pasa a una subcarpeta que se llama procesados, todo eso me funciona bien...

Esto es lo que llevo

'' ***************************************************************************''

''                               CORREOS AUDICASE                             ''

'' Propósito  : Revisa una carpeta de la bandeja de entrada y guarda la       ''

''              info en excel                                                 ''

'' Escrito     : 08-May-2012                      ''

'' ***************************************************************************''

' NOTAS:

' La Carpeta de la bandeja de entrada (Audicase) y el subfolder (Procesados) donde se guardarán los mensajes debe existir

' Este código requiere agregar una referencia al Microsoft Outlook 8.0 Object Model


Sub salvarcorreo()


'Declaración de variables

Dim appOl As New Outlook.Application

Dim ns As Outlook.Namespace

Dim Inbox As Outlook.MAPIFolder

Dim SubFolder As Outlook.MAPIFolder

Dim ProceFolder As Outlook.MAPIFolder

Dim Item As Object

Dim Atmt As Outlook.Attachment

Dim FileName As String

Dim i As Integer

Dim j As Integer

Dim varResponse As Variant

Dim cuerpo As Object

Dim cantidad As Integer

Set ns = appOl.GetNamespace("MAPI")

Set Inbox = ns.GetDefaultFolder(olFolderInbox)

Dim strBody As String


'Conteo de mensajes procesados

cantidad = 0


'Carpeta donde guarda los mensajes

Set ProceFolder = Inbox.Folders("Audicase").Folders("Procesados")


' Nombre de la subcarpeta de la bandeja de entrada

Set SubFolder = Inbox.Folders("Audicase")

i = 0


' Revisa si hay mensajes en la subcarpeta

If SubFolder.Items.Count = 0 Then

    MsgBox "No hay mensajes.", vbInformation, "No se encontraron mensajes"

    Exit Sub

End If


' Copia cada titulo de mensaje en la celda

i = 2

On Error Resume Next

For Each Item In SubFolder.Items


'*********************************Aqui va toda la Macro************************************

    Range("A2").Activate

    ActiveCell.FormulaR1C1 = Item.Subject

    ActiveCell.Offset(0, 1).Select

    ActiveCell.FormulaR1C1 = Item.ReceivedTime

    ActiveCell.Offset(0, 1).Select

    Item.Body.Copy

    ActiveCell..Paste


'*******************************************************************************************

    cantidad = cantidad + 1

    i = i + 1

Next Item



'Copia los correos procesados a la carpeta

For j = 0 To cantidad

    For Each Item In SubFolder.Items

        Item.Move ProceFolder

    Next Item

Next j



'Mesnaje de procesado

MsgBox "Se han copiado " & cantidad & " de elementos a Excel"


' Limpiar memoria

Set objItem = Nothing

Set Atmt = Nothing

Set Item = Nothing

Set ns = Nothing

Set appOl = Nothing

Exit Sub

End Sub

[/CODE]

Muchas gracias por la ayuda.....