VBScript – Exportar Tablas Recibidas por Correo a Excel

El siguiente VBScript es para automatizar la copia a Excel las tablas recibidas por correo electrónico, esto nos ahorrara tiempo en abrir una hoja de Excel y copiar tabla por tabla, el VBScript esta diseñado para copiar varias tablas a Excel sin copiar los comentarios del cuerpo de correo.

Ejemplo de Exportar Tablas a Excel

Recibo un correo como el mostrado en la imagen, vemos que contiene dos tablas y comentarios entre estos, con el VBScript Exportare automáticamente las dos tablas sin copiar comentarios, etc.

Al ejecutar el script se abre automáticamente Excel una nueva hoja y pega solo las tablas y obtendré como se muestra en la imagen siguiente.

Se crearon distintas variables del código cambiando su funcionamiento.

Instrucciones de Uso del VBScript

1.- Abrir el editor de Visual Basic (ALT+F11).

2.- Insertar un modulo nuevo (Insert > Module).

3.- Copiar el código VBScript.

4.- Opcional – Agregar botón de acceso rápido para ejecutar VBScript en Outlook

No es necesario realizar modificación alguna al menos que se indique en la variante de cada código.

Para mas información de configuración ver:

• Como utilizar el Editor VBA en Office (Utilizar Macros VBScript) 
• Outlook – Crear y configurar reglas
• Outlook – Opción ejecutar un script (run a script) no aparece en las reglas

VBScript para Exportar Tablas en misma hoja de Correo seleccionado a Excel

El siguiente código exporta todas las tablas contenidas en el correo en la misma hoja de Excel y al seleccionar varios correos con tablas exporta en un archivo distinto las tablas de cada correo.

Sub SaveEmailTablestoExcel()
Dim Item As MailItem, x%
Dim r As Object  'As Word.Range
Dim doc As Object 'As Word.Document
Dim xlApp As Object, xlWB As Object
Dim xlSheet As Object
Dim bXStarted As Boolean
Dim xRow As Integer
xRow = 1

     On Error Resume Next
     Set xlApp = GetObject(, "Excel.Application")
     If Err <> 0 Then
         Application.StatusBar = "Espera en lo que abre la aplicacion ... "
         Set xlApp = CreateObject("Excel.Application")
         bXStarted = True
     End If
     On Error GoTo 0

xlApp.Visible = True

For Each Item In Application.ActiveExplorer.Selection
'i = i + 1
'Set Item = Outlook.Application.ActiveExplorer.Selection.Item(i)
Set xlWB = xlApp.Workbooks.Add
xlApp.Visible = True
Set xlSheet = xlWB.Sheets(1)

Set doc = Item.GetInspector.WordEditor
    For x = 1 To doc.Tables.Count
        Set r = doc.Tables(x)
        r.Range.Copy
        xlSheet.Paste
        xRow = xRow + r.Rows.Count + 1
        xlSheet.Range("A" & CStr(xRow)).Select
        xlSheet.Columns.ColumnWidth = 20
        xlSheet.Rows.RowHeight = 15
    Next
    Set r = Nothing
    xRow = 1
    
Next

End Sub

VBScript para Exportar Tablas a distintas hojas de Correo seleccionado a Excel

El siguiente código exporta todas las tablas contenidas en el correo en distintas hojas de Excel y al seleccionar varios correos con tablas exporta en un archivo distinto las tablas de cada correo.

Sub SaveEmailTablestoExcel()
Dim Item As MailItem, x%
Dim r As Object  'As Word.Range
Dim doc As Object 'As Word.Document
Dim xlApp As Object, xlWB As Object
Dim xlSheet As Object
Dim bXStarted As Boolean

     On Error Resume Next
     Set xlApp = GetObject(, "Excel.Application")
     If Err <> 0 Then
         Application.StatusBar = "Espera en lo que abre la aplicacion ... "
         Set xlApp = CreateObject("Excel.Application")
         bXStarted = True
     End If
     On Error GoTo 0
    'Set xlWB = xlApp.Workbooks.Add
    'xlApp.Visible = True

For Each Item In Application.ActiveExplorer.Selection
'i = i + 1
'Set Item = Outlook.Application.ActiveExplorer.Selection.Item(i)
Set xlWB = xlApp.Workbooks.Add
xlApp.Visible = True

Set doc = Item.GetInspector.WordEditor

   If doc.Tables.Count > 1 Then
       'If there is more than one table
       'Copy each table into separate worksheet
            For x = 1 To doc.Tables.Count
                Set r = doc.Tables(x)
                r.Range.Copy
                xlSheetName = xlApp.ActiveSheet.Name
                Set xlSheet = xlWB.Sheets(xlSheetName)
                xlSheet.Paste
                xlSheet.Columns.ColumnWidth = 20
                xlSheet.Rows.RowHeight = 15
                If Not doc.Tables.Count = x Then
                    Set xlSheet = xlWB.Sheets.Add
                End If
        Next
    Else
        For x = 1 To doc.Tables.Count
            Set r = doc.Tables(x)
            r.Range.Copy
            Set xlSheet = xlWB.Sheets(1)
            xlSheet.Paste
            xlSheet.Columns.ColumnWidth = 20
            xlSheet.Rows.RowHeight = 15
        Next
    End If
     
Next

End Sub

Edición 08 Septiembre 2018 – Se agrega código ejecutable desde una regla para exportar tablas a Excel.

VBScript – Exportar automáticamente tablas a Excel de correo recibido.

El siguiente codigo de ejecuta por medio de una regla en Outlook para exportar las tablas de ciertos correos.

Sub SaveEmailTablestoExcel(Item As Outlook.MailItem)
Dim r As Object  'As Word.Range
Dim doc As Object 'As Word.Document
Dim xlApp As Object, xlWB As Object
Dim xlSheet As Object
Dim bXStarted As Boolean
Dim xRow As Integer
xRow = 1

     On Error Resume Next
     Set xlApp = GetObject(, "Excel.Application")
     If Err <> 0 Then
         Application.StatusBar = "Espera en lo que abre la aplicacion ... "
         Set xlApp = CreateObject("Excel.Application")
         bXStarted = True
     End If
     On Error GoTo 0

xlApp.Visible = True


Set xlWB = xlApp.Workbooks.Add
xlApp.Visible = True
Set xlSheet = xlWB.Sheets(1)

Set doc = Item.GetInspector.WordEditor
    For x = 1 To doc.Tables.Count
        Set r = doc.Tables(x)
        r.Range.Copy
        xlSheet.Paste
        xRow = xRow + r.Rows.Count + 1
        xlSheet.Range("A" & CStr(xRow)).Select
        xlSheet.Columns.ColumnWidth = 20
        xlSheet.Rows.RowHeight = 15
    Next
    Set r = Nothing
    xRow = 1

End Sub

Parte del código fue tomado de slipstick