Thread: Transfer data from Excel to Outlook Calendar

Hi Hatye

Don't know...have never done that. Do you want to overwrite a specific "Skole" appointment or would it be acceptable to delete all "Skole" appointments and then recreate them with the new data? (Don't know really if this can be done...just an alternative)

John

Hi Hatye

As you see, it doesn't work this way

if I transfered appointment that allready existed with same subject and time, the old one should have been overwrited

However, let's not give up just yet...let me (or someone else on the Forum) look at it.

I'll get back to you tomorrow and let you know what I can or cannot do.

John

Hi Hayte

This code takes the approach of deleting all "Skole" calendar entries then reinstating the new entries. Not the best approach admittedly but I'll follow up tomorrow.

Option Explicit
Sub Transfer_Outlook()
    Dim objApp As Outlook.Application
    Dim objNS As Outlook.Namespace
    Dim objFolder As Outlook.MAPIFolder
    Dim objRecip As Outlook.Recipient
    Dim objAppt As Outlook.AppointmentItem
    Dim UseSubject As String
    Dim UseLocation As String
    Dim UseBody As String
    Dim UseDate As Date
    Dim UseCategory As String
    Dim LR As Long
    Dim nCell As Range
    Dim Rng As Range
    Dim StartTime As String
    Dim EndTime As String
    DeleteSkoleAppointments    ' deletes previous Skole appointments
    On Error Resume Next
    Set objApp = CreateObject("Outlook.Application")
    On Error GoTo 0
    LR = Ark2.Range("A" & Rows.Count).End(xlUp).Row
    Set Rng = Ark2.Range("A2:A" & LR)
    For Each nCell In Rng
        If Not nCell = "" Then
            On Error Resume Next
            Set objNS = objApp.GetNamespace("MAPI")
            Set objFolder = objNS.GetDefaultFolder(olFolderCalendar)
            UseSubject = nCell.Offset(0, 0).Value    '& " - " & nCell.Offset(0, -4).Value
            UseDate = nCell.Offset(0, 1).Value
            UseLocation = nCell.Offset(0, 7).Value
            UseBody = nCell.Offset(0, 6).Value
            UseCategory = nCell.Offset(0, 8).Value
            StartTime = nCell.Offset(0, 2).Value
            EndTime = nCell.Offset(0, 4).Value
            If Not objFolder Is Nothing Then
                Set objAppt = objFolder.Items.Add
                If Not objAppt Is Nothing Then
                    With objAppt
                        .Start = UseDate + StartTime
                        .End = UseDate + EndTime
                        .Subject = UseSubject
                        .Location = UseLocation
                        .Body = UseBody
                        .Categories = UseCategory
                        .Save
                    End With
                End If
            Else
                'MsgBox "Could not find " & Chr(34) & nCell & Chr(34), , _
                 "User not found"
            End If
            On Error GoTo 0
        End If
    Next nCell
    Set objApp = Nothing
    Set objNS = Nothing
    Set objFolder = Nothing
    Set objRecip = Nothing
    Set objAppt = Nothing
End Sub
Sub DeleteSkoleAppointments()
' deletes all Skole Appointments in Outlook
    Dim olApp As Outlook.Application
    Dim OLF As Outlook.MAPIFolder
    Dim r As Long, dCount As Long
    On Error Resume Next
    Set olApp = GetObject("", "Outlook.Application")
    On Error GoTo 0
    If olApp Is Nothing Then
        On Error Resume Next
        Set olApp = GetObject("Outlook.Application")
        On Error GoTo 0
        If olApp Is Nothing Then
            MsgBox "Outlook is not available!"
            Exit Sub
        End If
    End If
    Set OLF = olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderCalendar)
    dCount = 0
    For r = OLF.Items.Count To 1 Step -1
        If TypeName(OLF.Items(r)) = "AppointmentItem" Then
            If InStr(1, OLF.Items(r).Categories, "Skole", vbTextCompare) = 1 Then
                OLF.Items(r).Delete
                dCount = dCount + 1
            End If
        End If
    Next r
    Set olApp = Nothing
    Set OLF = Nothing
End Sub

John

Keep it simple, you need only 2 variables:

Sub tst()
  on error resume next
  sq = Sheets(1).Cells(1).CurrentRegion

  With CreateObject("outlook.application")
    For j = 2 To UBound(sq)
    .GetNamespace("MAPI").GetDefaultFolder(olFolderCalendar).Items.Find("[location]='" & sq(j,8) &' and [start]=" & Format(CDate(sq(j,2) + sq(j,3)), "'dddd h:mm'")).Delete

      With .createitem(1)
        .Subject=sq(j,1)
        .Start=sq(j,2) + sq(j,3)
        .End=sq(j,4) + sq(j,5)
        .Body=sq(j,7)
        .Location=sq(j,8)
        .Categories=sq(j,9)
        .Save
      End With
    Next
  End With
End Sub