none
copy table in Outlook HTML mail and paste into Excel worksheet causes dates to be wrong in destination RRS feed

  • Question

  • 

    Need help in getting embedded table in email to be correctly copied into Excel. The Outlook VBA code copy the embedded table in current e-mail to the clipboard, then open a workbook, and paste the data into the 'data' worksheet at the first empty row, at column C. The problem that I am getting is that the dates in the original table are wrong when pasted into Excel. For example, a date like 8/9/2014 becomes 9/8/2014. It is not the format that is being changed, it is really the date being changed, that is in original table it is 8th of September 2014, but in Excel table it becomes 9th of August, 2014. When I do pastespecial in Excel, the only option it allows is pastevalues, others options such as pasteallexceptborders, pasteformat, pastevaluesandnumberformat just don't work, giving a run time error '1004'.

    Sub Upload()
        Dim ExcelApp As Object, wb As Workbook, ws As Worksheet, rng As Range
        Dim objDoc As Object, objTbl As Object, objItem As MailItem
        Dim lngRows As Long, lngColumns As Long, i As Long, lngCount As Long
        Dim lngFirstRow As Long, lngLastRow As Long
        Dim wbOpened As Boolean
    
        Set ExcelApp = CreateObject("Excel.application")
        For Each wb In Workbooks
            If wb.Name = "Tracking Data Recovery.xlsm" Then
                wbOpened = True
                Exit For
            Else
                wbOpened = False
            End If
        Next
        If wbOpened = False Then
            Workbooks.Open "d:\documents\Tracking Data Recovery.xlsm"
        End If
        Set wb = Workbooks("Tracking Data Recovery.xlsm")
        Set ws = wb.Worksheets("data")
        ws.Activate
        ExcelApp.Visible = True
        ExcelApp.ActiveWindow.WindowState = xlMaximized
        ExcelApp.ScreenUpdating = False
        Set objItem = GetCurrentItem()
        
        objItem.Display
        
        Set objDoc = ActiveInspector.WordEditor
        If objDoc.tables.Count = 0 Then
            MsgBox "This message doesn't contain a table!", vbExclamation
            Exit Sub
        End If
        Set objTbl = objDoc.tables(1)
        lngRows = objTbl.Rows.Count
        lngColumns = objTbl.Columns.Count
        objTbl.Range.Copy
          
        With ws
            lngFirstRow = .Cells(.Rows.Count, "C").End(xlUp).Row + 1
            Range("C" & lngFirstRow).PasteSpecial Paste:=xlPssteValues
            lngLastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
        End With
        ExcelApp.DisplayAlerts = False
        ExcelApp.CutCopyMode = False
    
        objItem.Close discard
        wb.Close, savechanges
        ExcelApp.ScreenUpdating = True
        ExcelApp.DisplayAlerts = True
        Set objItem = Nothing
        Set objDoc = Nothing
    End Sub
    
    Function GetCurrentItem() As Object
    Dim objApp As Outlook.Application
    Set objApp = Application
    On Error Resume Next
    Select Case TypeName(objApp.ActiveWindow)
    Case "Explorer"
    Set GetCurrentItem = objApp.ActiveExplorer.Selection.Item(1)
    Case "Inspector"
    Set GetCurrentItem = objApp.ActiveInspector.CurrentItem
    Case Else
    End Select
    End Function
    

    I have this data in the original table:

    Equipment        Date (DD/MM/YYYY)

    51712              8/9/2014

    07065              7/9/2014

    17288              6/9/2014

    After it is pasted into Excel, I got this:

    Equipment       Date (DD/MM/YYYY)

    51712             9/8/2014

    07065             9/7/2014

    17288             9/6/2014

    If I do step-by-step debugging, after the objTbl.Range.copy, I go to Excel worksheet 'data', select the first empty cell in column C, do a paste or paste values I get the correct date, only when I paste using VBA the dates are wrong.

    Just to clarify, it is not the resultant cell format that make it display as if the date becomes m/d/yyyy, using Excel format long date, it actually displays 9th August, 2014, 9th July 2014 and 9th June 2014, which are all wrong.

    Is there a better way to do this or to prevent it from wrongfully converting the dates? How about another few lines of codes to correct the dates?


    Valuable skills are not learned, learned skills aren't valuable.

    Saturday, September 13, 2014 7:16 AM

All replies

  • What's version of Excel are you using?

    I can paste the table correctly manually. Could you reproduce the issue when you copy and paste it from Outlook to Excel?

    Thursday, December 4, 2014 8:54 AM
  • Office 2013.

    No problem manually copy and paste, I mentioned this in my post. Problem occurred only when doing the same in VBA.


    Valuable skills are not learned, learned skills aren't valuable.

    Thursday, December 4, 2014 3:01 PM
  • Why copy and paste, which is clunky? Why not read the table cells and write the values to the corresponding Worksheet cells? That way you can tell Excel to expect a date and the format should not be screwed up.

    Reading between the lines, you want the table data to start on the next row in column C, and the table has two Columns or more, one of which is a date.

    I assume also that the code is intended to run from Outlook, as there is some incompatible code in your original? And the workbook is not saved and thus the process would be pointless.

    The following code uses Late Binding to Excel so there is no need for a reference to the Excel object library.

    If you use the following code (which works on that premise) the following should put the dates in date format and numbers as numbers, with the format of the target columns.

    Sub Upload()
    Dim ExcelApp As Object, wb As Object, ws As Object, rng As Object
    Dim objDoc As Object, objTbl As Object, objItem As MailItem
    Dim lngRows As Long, lngColumns As Long, i As Long, j As Long, lngCount As Long
    Dim lngFirstRow As Long, lngLastRow As Long
    Dim wbOpened As Boolean

        Set ExcelApp = CreateObject("Excel.application")
        For Each wb In ExcelApp.Workbooks
            If wb.Name = "Tracking Data Recovery.xlsm" Then
                wbOpened = True
                Exit For
            Else
                wbOpened = False
            End If
        Next
        If wbOpened = False Then
            ExcelApp.Workbooks.Open "d:\documents\Tracking Data Recovery.xlsm"
        End If
        Set wb = ExcelApp.Workbooks("Tracking Data Recovery.xlsm")
        Set ws = wb.Worksheets("data")
        ws.Activate
        ExcelApp.Visible = True
        ExcelApp.ActiveWindow.WindowState = -4137
        'ExcelApp.ScreenUpdating = False
        Set objItem = GetCurrentItem()

        objItem.Display

        Set objDoc = ActiveInspector.WordEditor
        If objDoc.tables.Count = 0 Then
            MsgBox "This message doesn't contain a table!", vbExclamation
            Exit Sub
        End If
        Set objTbl = objDoc.tables(1)
        lngRows = objTbl.Rows.Count
        lngColumns = objTbl.Columns.Count
        'objTbl.Range.Copy

        'With ws
        'Range("C" & lngFirstRow).PasteSpecial Paste:=xlPssteValues
        'lngLastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
        lngFirstRow = ws.cells(ws.Rows.Count, "C").End(-4162).Row + 1
        For i = 2 To lngRows
            For j = 1 To lngColumns
                Set rng = objTbl.Cell(i, j).Range
                rng.End = rng.End - 1
                'MsgBox rng.Text & vbCr & lngFirstRow
                If IsNumeric(rng.Text) Then
                    ws.cells(lngFirstRow, j + 3 - 1) = Val(rng.Text)
                ElseIf IsDate(rng.Text) Then
                    ws.cells(lngFirstRow, j + 3 - 1) = CDate(rng.Text)
                Else
                    ws.cells(lngFirstRow, j + 3 - 1) = rng.Text
                End If
            Next j
            lngFirstRow = lngFirstRow + 1
        Next i
        'End With
        ExcelApp.DisplayAlerts = False
        ExcelApp.CutCopyMode = False

        objItem.Close 0
        wb.Close savechanges:=True
        ExcelApp.ScreenUpdating = True
        ExcelApp.DisplayAlerts = True
        Set objItem = Nothing
        Set objDoc = Nothing
    End Sub

    Damn! I have just noticed the date on this thread :(


    Graham Mayor - Word MVP
    www.gmayor.com


    Thursday, December 4, 2014 3:36 PM