2
votes

I'm fairly new to programming. Could you, please, help me identify the problem and possibly solve it. The macro below is supposed to extract tables from an e-mail folder. The first two parts work pretty well: I can open up the Excel export file and choose the email folder. However, export to the file fails as a target spreadsheet appears not to be recognized as an object. Thank you in advance.

Sub FolderEmptyCellTable()

Dim Mails As Outlook.MailItem
Dim NSP As Outlook.NameSpace
Dim Folder As Outlook.MAPIFolder
Dim i As Integer
Dim WordDoc, Selection, XL, Tabl, WL, WB As Object

'Open up an Excel file
Set XL = CreateObject("Excel.Application")
XL.Visible = True
Set WB = XL.Workbooks.Open("C:\User\Desktop\Task\File.xlsx")

'Choose the export folder
Set NSP = Application.GetNamespace("MAPI")
Set Folder = NSP.PickFolder

'Run through e-mails collecting tables

For Each Mails In Folder.Items
Set WordDoc = Mails.GetInspector.WordEditor
If WordDoc.Tables.Count >= 1 Then
For i = 1 To WordDoc.Tables.Count
    Set Tabl = WordDoc.Tables(i)
    Tabl.Range.Copy
 'Insert*emphasized text* each table to a separate sheet
    Set WL = WB.Sheets(i)
    'Here is where the error 424 occurs: Object required  
    **WL.Range("a1").End(xlDown).Offset(1, 0).Select**
    Selection.Parent.PasteSpecial Format:="Text", Link:=False, _
               DisplayAsIcon:=False
 Next i

 Else: MsgBox "No tables found"
 Exit Sub

 End If

 Next Mails

 End Sub
2
You go Down. What is the address of that cell where you paste?JohnyL
Probably, I should have used .Range("A65536").End(xlUp).Select in order to find last used cell in column A and then select the one below it.All_in_A

2 Answers

0
votes

Declare like this:

Dim WordDoc     As Object
Dim Selection   As Object
Dim XL          As Object
Dim Tabl        As Object
Dim WL          As Worksheet
Dim WB          As Workbook

Thus, you will make sure that they are objects indeed. In your code, only WB is object, the others are of type Variant.

0
votes

Thanks to a colleague of mine, the issue has been resolved.

Sub FolderEmptyCellTable()
Dim Mails As Outlook.MailItem
Dim NSP As Outlook.NameSpace
Dim Folder As Outlook.MAPIFolder
Dim XL As Object
Dim WB As Workbook
Dim WS As Worksheet
Dim WL As Object
Dim WordDoc As Object
Dim Tabl As Object
Dim i As Integer
Dim Selection As Object

Set XL = CreateObject("Excel.Application")
XL.Visible = True
Set WB = Workbooks.Open("C:\User\Desktop\Task\File.xlsx")
Set NSP = Application.GetNamespace("MAPI")
Set Folder = NSP.PickFolder
Dim lastRow As Integer

For Each Mails In Folder.Items
Set WordDoc = Mails.GetInspector.WordEditor
If WordDoc.Tables.Count >= 1 Then
    For i = 1 To WordDoc.Tables.Count
        Set Tabl = WordDoc.Tables(i)
        Tabl.Range.Copy
        Set WS = WB.Worksheets(i)
        lastRow = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row + 1
        WS.Range("A" & lastRow).PasteSpecial Paste:=xlPasteValues
    Next i
Else
    MsgBox "No tables found"
    GoTo LabelNext
End If
LabelNext:
Next Mails
End Sub