Object doesn't support this property or method

[Auri]

Hi, I have encountered a problem whereby this line

strTo = strTo & .Cells(cel.Row, "j").Value & "; "

is causing an error. What I wanted this entire thing to do is when I select an item (column C) from the table, it is supposed to take the expiry date from column F and set it as a reminder, and also send it as an appointment by using the email from column J and send it to them. It should be allowed to take in multiple emails from that cell that will be sending to them.

Sub EnterInCalendar()
Dim xOutApp As Object, cel As Range
Dim olMailItm As Object
Dim iCounter As Integer
Dim strTo As String
Dim i As Integer

strTo = ""
i = 1

If Selection.Columns.Count > 1 Or Selection.Column <> 3 Then
    MsgBox "Select in column C only."
    Exit Sub
End If

Set xOutApp = CreateObject("Outlook.Application")
Set olMailItm = xOutApp.CreateItem(0) 'empty email
'newMail.RecipIents.Add(ToAddress)
'newMail.RecipIents.Add(ToAddress1)

For Each cel In Selection
    With xOutApp.CreateItem(1)
        .Subject = cel.Value
        .Start = cel(1, 4).Value + TimeValue("9:00:00")
        .End = cel(1, 4).Value + TimeValue("9:30:00")
        .ReminderSet = True
        .ReminderMinutesBeforeStart = 10080
        .BusyStatus = 5
        .Save
    End With
    
    'Using the email, add multiple recipients, using a list of addresses in column J.
   With ActiveSheet.ListObjects("Table1") 'change sheet name where list is kept.
    Do
    strTo = strTo & .Cells(cel.Row, "j").Value & "; "
    i = i + 1
    Loop Until IsEmpty(.Cells(j, 1))
    
       'Do additional formatting on the BCC and Subject lines, add the body text from the spreadsheet, and send.
       .To = strTo
       '.CC = test@company.com; test2@company.com
       .Subject = "Test"
       .Body = "Test Test"
       .Display
   End With
       
    Cells(cel.Row, "L") = "c"
Next

Set xOutApp = Nothing
Set olMailItm = Nothing
End Sub

Anyone who knows how to fix this, please help. Thank you!

 

[Auri]

I tried adding

.Recipients.ResolveAll

just before

.Display

, it only worked for a single email in a cell but doesn't work for multiple emails in a cell.

 

[RoryA]

Try something like this:

Sub EnterInCalendar()
Dim xOutApp As Object, cel As Range
Dim myItem As Object
Dim strTo As String
Dim myAttendee As Object

Const olMeeting As Long = 1
Const olRequired As Long = 1

strTo = ""

If Selection.Columns.Count > 1 Or Selection.Column <> 3 Then
    MsgBox "Select in column C only."
    Exit Sub
End If

Set xOutApp = CreateObject("Outlook.Application")

For Each cel In Selection
    Set myItem = xOutApp.CreateItem(1)
    
    With myItem
        .MeetingStatus = olMeeting
        .Subject = cel.Value
        .Start = cel(1, 4).Value + TimeValue("9:00:00")
        .End = cel(1, 4).Value + TimeValue("9:30:00")
        .ReminderSet = True
        .ReminderMinutesBeforeStart = 10080
        .BusyStatus = 5
        Dim Addresses() As String
        Addresses = Split(Cells(cel.Row, "j").Value, ";")
        Dim n As Long
        For n = LBound(Addresses) To UBound(Addresses)
            Set myAttendee = .Recipients.Add(Trim$(Addresses(n)))
            myAttendee.Type = olRequired
        Next n
        .Recipients.resolveall
        .Display
'        .Send
        
    End With

    Cells(cel.Row, "L") = "c"

Next

Set xOutApp = Nothing
Set myItem = Nothing

End Sub

 

[Auri]

OMG it worked! Thanks for the help! Really appreciated!