none
Copying table data from the body of an email in Outlook 2010 and paste special values in Excel 2010 RRS feed

  • Question

  • Hi,

    I am Trying to Copy a table out of the body of an email and a paste special values into excel.

    I have the below code which work perfectly except the data i am copying contains mobile phone numbers that begin with 0's, so when it pastes into excel the 0's are dropped of the front of the mobile phone numbers. Can you please help me with the correct syntax to paste values so it wont drop the 0's?

    Sub dd()
    Dim item As MailItem, x%
    Dim r As Object  'As Word.Range
    Dim doc As Object 'As Word.Document
    Dim xlApp As Object, wkb As Object
    Set xlApp = CreateObject("Excel.Application")
    Set wkb = xlApp.Workbooks.Add
    xlApp.Visible = True
    
    Dim wks As Object
    Set wks = wkb.Sheets(1)
    
    For Each item In Application.ActiveExplorer.Selection
    Set doc = item.GetInspector.WordEditor
        For x = 1 To doc.tables.Count
         Set r = doc.tables(x)
            r.Range.copy
           wks.Paste
           wks.Cells(wks.Rows.Count, 1).End(3).Offset(1).Select
        Next
    Next
    End Sub
    

    Any help would be greatly appreciated.

    Thanks in advance

    Andy

    Monday, October 7, 2013 2:17 AM

Answers

  • The problem is due to the cell format.

    Try adding

    wks.Columns("F:F").NumberFormat = "@"

    Note: F:F should be substitute by the letter of the column you are going to fill with the phone numbers.

    And changing

    wks.Paste

    With

    wks.PasteSpecial Format:="Text", Link:=False, DisplayAsIcon:= False

    As shown below

    Sub dd()
    Dim item As MailItem, x%
    Dim r As Object  'As Word.Range
    Dim doc As Object 'As Word.Document
    Dim xlApp As Object, wkb As Object
    Set xlApp = CreateObject("Excel.Application")
    Set wkb = xlApp.Workbooks.Add
    xlApp.Visible = True
    
    Dim wks As Object
    Set wks = wkb.Sheets(1)
    wks.Columns("F:F").NumberFormat = "@"
    
    For Each item In Application.ActiveExplorer.Selection
        Set doc = item.GetInspector.WordEditor
        For x = 1 To doc.tables.Count
            Set r = doc.tables(x)
            r.Range.copy
            wks.PasteSpecial Format:="Text", Link:=False, DisplayAsIcon:= False
            wks.Cells(wks.Rows.Count, 1).End(3).Offset(1).Select
        Next
    Next
    End Sub
    
    

    I don't have time to check the code but it should work fine.

    Good luck! :)

    • Marked as answer by ARod_87 Thursday, October 10, 2013 10:20 PM
    Monday, October 7, 2013 3:53 PM

All replies

  • The problem is due to the cell format.

    Try adding

    wks.Columns("F:F").NumberFormat = "@"

    Note: F:F should be substitute by the letter of the column you are going to fill with the phone numbers.

    And changing

    wks.Paste

    With

    wks.PasteSpecial Format:="Text", Link:=False, DisplayAsIcon:= False

    As shown below

    Sub dd()
    Dim item As MailItem, x%
    Dim r As Object  'As Word.Range
    Dim doc As Object 'As Word.Document
    Dim xlApp As Object, wkb As Object
    Set xlApp = CreateObject("Excel.Application")
    Set wkb = xlApp.Workbooks.Add
    xlApp.Visible = True
    
    Dim wks As Object
    Set wks = wkb.Sheets(1)
    wks.Columns("F:F").NumberFormat = "@"
    
    For Each item In Application.ActiveExplorer.Selection
        Set doc = item.GetInspector.WordEditor
        For x = 1 To doc.tables.Count
            Set r = doc.tables(x)
            r.Range.copy
            wks.PasteSpecial Format:="Text", Link:=False, DisplayAsIcon:= False
            wks.Cells(wks.Rows.Count, 1).End(3).Offset(1).Select
        Next
    Next
    End Sub
    
    

    I don't have time to check the code but it should work fine.

    Good luck! :)

    • Marked as answer by ARod_87 Thursday, October 10, 2013 10:20 PM
    Monday, October 7, 2013 3:53 PM
  • Hi Maurizio,

    Thank you very much for your reply.

    This works almost perfectly!

    one minor issue, it is now inserting a blank row every 6th row. Its not the end of the world as i can just filter out the blanks and delete the rows.

    But if you could tell me how i can stop this it would be greatly appreciated.

    Cheers

    Andy

    • Proposed as answer by Maurizio Molle Thursday, October 10, 2013 8:57 AM
    Monday, October 7, 2013 11:00 PM
  • Hi Andy,

    I think the blank lines are due to the table format.

    Anyway you can create a macro that remove empty lines.

    This is an example:

    Public Sub removeblankrows(ByRef r As Range)
        Set r = r.Offset(1, 0)
        blanks = 0
        Do While blanks < 5
            If r.Offset(-1, 0).Value = "" Then
                blanks = blanks + 1
                r.Offset(-1, 0).Rows.Delete
            Else
                blanks = 0
            End If
            Set r = r.Offset(1, 0)
        Loop
    End Sub

    you should pass to the function the first cell of a column you are sure will never be empty in the rows (for instance an id field) as parameter. Anyway I created it in order to handle till 5 consecutive blanks.

    Please let me know if it works.

    Bye bye,

    Maurizio

    Wednesday, October 9, 2013 2:46 PM
  • Hi Maurizio,

    Thank you very much for your help.

    It all works very well.

    Regards

    Andy

    Thursday, October 10, 2013 10:22 PM
  • i get an error at ... Plase help me
    For Each item In Application.ActiveExplorer.Selection
    Wednesday, December 30, 2015 4:14 PM