Creating an outlook Task from excel

Hello jsmity,

I thought this was familiar. What do you want to go where in the Outlookk Task?

Hi jsmity
This code is in the attached and appears to do as you require. Let me know of issues.

Option Explicit
Sub Create_Task()
    Dim olApp As Object
    Dim olNs As Object
    Dim Fldr As Object
    Dim olTsk As Object
    Dim LR As Long
    Dim Rng As Range
    Dim Cell As Range
    Application.ScreenUpdating = False
    LR = Sheet1.Range("A" & Rows.Count).End(xlUp).Row
    ActiveSheet.Range("A4:AH" & LR).AutoFilter Field:=2, Criteria1:="="
 
    Set Rng = Range("A5:A" & LR).SpecialCells(xlCellTypeVisible)
    Set olApp = CreateObject("Outlook.Application")
    Set olNs = olApp.GetNamespace("MAPI")
    Set Fldr = olNs.GetDefaultFolder(13)
    Set olTsk = olApp.CreateItem(3)
 
    For Each Cell In Rng
        On Error Resume Next
        Set olTsk = Fldr.Items.Find("[Company] = " _
                & Sheet1.Range("D" & Cell.Row).Value & " and [DueDate] = " _
                & Format(Sheet1.Range("G" & Cell.Row), "ddd mm/dd/yyyy") & "")
        On Error GoTo 0
 
        If olTsk Is Nothing Then
            Set olTsk = Fldr.Items.Add
            With olTsk
                .Subject = Sheet1.Range("D" & Cell.Row).Value
                .Body = Sheet1.Range("E" & Cell.Row).Value
                .Companies = Sheet1.Range("D" & Cell.Row).Value
                .DueDate = Sheet1.Range("G" & Cell.Row).Value
                .ContactNames = Sheet1.Range("F" & Cell.Row).Value
                .Save
            End With
        End If
    Next Cell
    Set olTsk = Nothing
    Set olApp = Nothing
    ActiveSheet.ShowAllData
    Application.ScreenUpdating = True
End Sub

Hi jsmity

Try the attached. The code is designed to fire on right click of any Open Actions cell in the range of D4 through G and last row. Let me know of issues.