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.

Ejemplo correo con tablas para copiar a excel

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.

Ejemplo tablas exportadas a excel con VBScript

 

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:

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

Parte del código fue tomado de slipstick

Fernando O.

Soy analista de sistemas actualmente trabajo en una empresa con mas de 200 empleados que utilizan equipo de computo al cual se les da soporte en el departamento.
Uno de mis pasatiempos fuera de la empresa es escribir artículos para PortalMasTips donde documento los problemas, inquietudes y detalles interesantes que se presentan.

Deja un comentario...

Este sitio usa Akismet para reducir el spam. Aprende cómo se procesan los datos de tus comentarios.

Compartir2
Twittear
Pin
Más en Outlook VBScript
VBScript – Guardar asunto de correos en un TXT en Outlook

VBScript – Responder automáticamente determinado correo electrónico 

Outlook – Opción ejecutar un script (run a script) no aparece en las reglas

Cerrar