VBA - Connect excel with Outlook

P

Phil810

New Member
Joined
Sep 18, 2018
Messages
13
Hello,

I have a problem with VBA when trying to look at multiple cells and compare them to a criteria. I am new to VBA but I dont understand why this problem is happening.

The matter at hand is, that im trying to link excel with outlook in order to get my work shifts from excel into outlook which is then connected to my phone.

I have the code that connects me with outlook sorted. I am able to look at a single cell and if the requirements are met then it will make a entry in outlook.

The problem is, that when I try to look at multiple cells with the same criteria as before, then it gives me an error message saying: "Runtime error: 13 type mismatch"

I have no idea why this is happening.

Here is the code so far and the excel sheet:

Code: 
Sub OpdaterOutlook()


Dim obJ0L As Object
Set obJ0L = CreateObject("Outlook.Application")




Set obJ0L = New Outlook.Application


Dim ONS As Outlook.Namespace
Set ONS = obJ0L.GetNamespace("MAPI")


Dim CAL_FOL As Outlook.Folder
Set CAL_FOL = ONS.GetDefaultFolder(olFolderCalendar)


Dim myapt As Outlook.AppointmentItem
Set myapt = CAL_FOL.Items.Add(olAppointmentItem)




With myapt
Dim MyCheck As String
MyCheck = "dag"
MyRange = Range("D10:D17")
MyRange2 = Range("B10:B17")


        If MyCheck = MyRange Then
        .Start = MyRange2 + TimeValue("06:45:00")

        .End = MyRange2 + TimeValue("15:00:00")

        .Subject = "Dagsvagt"
    End If

    If Sheets("MIT TIMEREGNSKAB 2017-2018").Range("D10") = "aften" Then
        .Start = Range("B10") + TimeValue("14:45:00")
        .End = Range("B10") + TimeValue("23:00:00")
        .Subject = "Aftenvagt"
    End If

    If Sheets("MIT TIMEREGNSKAB 2017-2018").Range("D10") = "nat" Then
        .Start = Range("B10") + TimeValue("22:45:00")
        .End = Range("B11") + TimeValue("07:00:00")
        .Subject = "Nattevagt"

    End If

    .Save
End With


End Sub
And about 30 min ago I knew nothing about VBA, so bare with me if the are any bad syntax.


The first column "Dato" is B10:B40 and D10:40 is the "Vagt" column
DatoUgedagVagtEkstra timerTimer
Over
Arbejde
01-majtirsdagdag8,25
02-majonsdagaften8,98
03-majtorsdagaften816,98
04-majfredagaften8,98
05-majlørdagaften8,98
06-majsøndagaften8,98
07-majmandagaften8,98
08-majtirsdagaften8,98
09-majonsdagovertid aft udb17,96
10-majtorsdagaften8,98
11-majfredag
12-majlørdag
13-majsøndag
14-majmandag
15-majtirsdag
16-majonsdag4,54,5
17-majtorsdagdag19,25
18-majfredagdag8,25
19-majlørdag
20-majsøndag
21-majmandag
22-majtirsdagdag1,259,5
23-majonsdagdag1,7510
24-majtorsdag
25-majfredagaften8,98
26-majlørdagaften8,2517,23
27-majsøndagaften8,2517,23
28-majmandag
29-majtirsdag
30-majonsdag
31-majtorsdag

<tbody>
</tbody>


I hope someone can help me :)
 
Last edited by a moderator:
Sort by date Sort by votes
Re: VBA - Connect excel with Outlook problem?!

Sorry, little error in the function, here is the one to copy-paste

Code: 
Public Function CheckAppointmentExists(argCheckDate As Date, argCheckSubject As String) As Boolean
  Dim oApp As Outlook.Application
  Dim oNameSpace As Outlook.Namespace
  Dim oApptItem As Outlook.AppointmentItem
  Dim oFolder As Outlook.MAPIFolder
  Dim oMeetingoApptItem As Outlook.MeetingItem
  Dim oObject As Object
  On Error Resume Next
  ' check if Outlook is running
  Set oApp = GetObject("Outlook.Application")
  If Err <> 0 Then
    'if not running, start it
    Set oApp = CreateObject("Outlook.Application")
  End If
  Set oNameSpace = oApp.GetNamespace("MAPI")
  Set oFolder = oNameSpace.GetDefaultFolder(olFolderCalendar)
  CheckAppointmentExists = False
  For Each oObject In oFolder.Items
    If oObject.Class = olAppointment Then
      Set oApptItem = oObject
      If oApptItem.Start = argCheckDate Then
        CheckAppointmentExists = True
      End If
    End If
  Next oObject
  Set oApp = Nothing
  Set oNameSpace = Nothing
  Set oApptItem = Nothing
  Set oFolder = Nothing
  Set oObject = Nothing
End Function
 
Upvote 0

Excel Facts

Format cells as currency
Select range and press Ctrl+Shift+4 to format cells as currency. (Shift 4 is the $ sign).
Re: VBA - Connect excel with Outlook problem?!

Again thank you very much Kamolga - it works like a charm! If its not too much I was wondering if its possible to add some code in which it checks weather there is an existing appointment before adding a new one. This is so I dont put in a workshift in a day in which I maybe have a meeting or something else which is important and needs my attention so I can decide weather if the existing appointment is more important. Maybe like a text box or I dont know if something like that is possible? If its not, then im also happy enough with the code I got, and I can modify it to the rest of my datasheet :)
 
Upvote 0
Re: VBA - Connect excel with Outlook problem?!

Hi,

I did it quick and durty but it works. Basically I took the function "is there an appointment with the same start and subject" (to avoid duplicate) and modified it to see if there is already an appointment on that day.
Code: 
Public AppOndaySubj As String
on top of the module and
Code: 
Public Function appOnDay(chDate As Date) As Boolean
  Dim oApp As Outlook.Application
  Dim oNameSpace As Outlook.Namespace
  Dim oApptItem As Outlook.AppointmentItem
  Dim oFolder As Outlook.MAPIFolder
  Dim oMeetingoApptItem As Outlook.MeetingItem
  Dim oObject As Object
  On Error Resume Next
  ' check if Outlook is running
  Set oApp = GetObject("Outlook.Application")
  If Err <> 0 Then
    'if not running, start it
    Set oApp = CreateObject("Outlook.Application")
  End If
  Set oNameSpace = oApp.GetNamespace("MAPI")
  Set oFolder = oNameSpace.GetDefaultFolder(olFolderCalendar)
  appOnDay = False
  For Each oObject In oFolder.Items
    If oObject.Class = olAppointment Then
      Set oApptItem = oObject
      If (oApptItem.Start >= chDate And oApptItem.Start <= DateAdd("d", 1, chDate)) Then
      appOnDay = True
        AppOndaySubj = oApptItem.Subject
        Exit Function
      End If
    End If
  Next oObject
  
  Set oApp = Nothing
  Set oNameSpace = Nothing
  Set oApptItem = Nothing
  Set oFolder = Nothing
  Set oObject = Nothing
End Function

then modify the macro by
Code: 
Sub OpdaterOutlook()
Dim obJ0L As Object
Set obJ0L = CreateObject("Outlook.Application")
Set obJ0L = New Outlook.Application
Dim ONS As Outlook.Namespace
Set ONS = obJ0L.GetNamespace("MAPI")
Dim CAL_FOL As Outlook.Folder
Set CAL_FOL = ONS.GetDefaultFolder(olFolderCalendar)
Dim myapt As Outlook.AppointmentItem
Dim dCell As Range
 'Go through the cells with "dag" value
    For Each dCell In Range("D10:D40")
        If dCell.Value = "dag" Then
          'if there is an appointment with same starting time and subject
            If CheckAppointmentExists(dCell.Offset(0, -2) + TimeValue("06:45:00"), "Dagsvagt") = True Then
             'don't do anything -> avoid duplicate
               GoTo NoEntry
              Else
               'if already an entry on that day
                        If appOnDay(dCell.Offset(0, -2)) = True Then
                          'ask if entering the appointment
                           answer = MsgBox("There is already an entry '" & AppOndaySubj & "' on " & dCell.Offset(0, -2) & "." & Chr(13) & Chr(10) & "Do you want to enter a 'Dagvast' item from 6:45 until 15:00 anyway?", vbYesNo)
                            If answer = vbYes Then
                               GoTo EnterAppointment
                            Else
                                GoTo NoEntry:
                            End If
                        End If
EnterAppointment:
                   Set myapt = CAL_FOL.Items.Add(olAppointmentItem)
                   With myapt
                           .Start = dCell.Offset(0, -2) + TimeValue("06:45:00")
                           .End = dCell.Offset(0, -2) + TimeValue("15:00:00")
                           .Subject = "Dagsvagt"
                       .Save
                   End With
               End If
         End If
NoEntry:
    Next dCell
End Sub

You can still download the file if needed
 
Last edited:
Upvote 0
Re: VBA - Connect excel with Outlook problem?!

Again thank you very much. Now ive created my desired code. The is only one problem accuring now - It says that my procedure is too large - Fine I fixed that by splitting it up into multiple subs and then calling them one by one:

Sub MainMacro()
Call OpdaterOutlook
Call OpdaterOutlook1
Call OpdaterOutlook2
End Sub

The only problem is, that it does not compile the Public function you made to check for existing dates - how do I implement that?
 
Upvote 0
Re: VBA - Connect excel with Outlook problem?!

So to sum up - it has started dublicating again..
 
Upvote 0
Re: VBA - Connect excel with Outlook problem?!

We have two (public) functions,:
-1 is CheckAppointmentExists and that is the one that avoids the duplicates.
The second, appOnDay, is only checking if there is something already.

By the way, it should ask if you want to put a new appointment as you have already one.
The fact that they are public means they work everywhere. You can make them private and working only in their module.

The only explanation is that somewhere in your code you have
Code: 
[LEFT][COLOR=#333333][FONT=monospace]CAL_FOL.Items.Add(olAppointmentItem)[/FONT][/COLOR][/LEFT]
without checking checkappointmentexists and apponday.

If you run the 3 subs one by one but 2 times in a row, you should be able to identify wich one writes duplicates.
If you can't find it, can you share your file (save to one drive and click share. Below right column, you can get a link) or share the subs?
​
​

Note: I some point I pasted the wrong version of checkappointexists. Here is the good one again

Code: 
Public Function CheckAppointmentExists(argCheckDate As Date, argCheckSubject As String) As Boolean
  Dim oApp As Outlook.Application
  Dim oNameSpace As Outlook.Namespace
  Dim oApptItem As Outlook.AppointmentItem
  Dim oFolder As Outlook.MAPIFolder
  Dim oMeetingoApptItem As Outlook.MeetingItem
  Dim oObject As Object
  On Error Resume Next
  ' check if Outlook is running
  Set oApp = GetObject("Outlook.Application")
  If Err <> 0 Then
    'if not running, start it
    Set oApp = CreateObject("Outlook.Application")
  End If
  Set oNameSpace = oApp.GetNamespace("MAPI")
  Set oFolder = oNameSpace.GetDefaultFolder(olFolderCalendar)
  CheckAppointmentExists = False
  For Each oObject In oFolder.Items
    If oObject.Class = olAppointment Then
      Set oApptItem = oObject
      If oApptItem.Start = argCheckDate Then
        CheckAppointmentExists = True
      End If
    End If
  Next oObject
  Set oApp = Nothing
  Set oNameSpace = Nothing
  Set oApptItem = Nothing
  Set oFolder = Nothing
  Set oObject = Nothing
End Function
 
Last edited:
Upvote 0
Re: VBA - Connect excel with Outlook problem?!

As of now the subs are without the 'apponday' part. But that shouldnt matter. It worked fine before i split it up...I cant quite find the error... So ill just post the first sub of three (its long but its basically the same over and over again just a new month..:

Public Function CheckAppointmentExists(argCheckDate As Date, argCheckSubject As String) As Boolean
Dim oApp As Outlook.Application
Dim oNameSpace As Outlook.Namespace
Dim oApptItem As Outlook.AppointmentItem
Dim oFolder As Outlook.MAPIFolder
Dim oMeetingoApptItem As Outlook.MeetingItem
Dim oObject As Object
On Error Resume Next
' check if Outlook is running
Set oApp = GetObject("Outlook.Application")
If Err <> 0 Then
'if not running, start it
Set oApp = CreateObject("Outlook.Application")
End If
Set oNameSpace = oApp.GetNamespace("MAPI")
Set oFolder = oNameSpace.GetDefaultFolder(olFolderCalendar)
CheckAppointmentExists = False
For Each oObject In oFolder.Items
If oObject.Class = olAppointment Then
Set oApptItem = oObject
If oApptItem.Start = argCheckDate Then
CheckAppointmentExists = True
End If
End If
Next oObject
Set oApp = Nothing
Set oNameSpace = Nothing
Set oApptItem = Nothing
Set oFolder = Nothing
Set oObject = Nothing
End Function
Sub MainMacro()
Call OpdaterOutlook
Call OpdaterOutlook1
Call OpdaterOutlook2


End Sub
Sub OpdaterOutlook()
Dim obJ0L As Object
Set obJ0L = CreateObject("Outlook.Application")
Set obJ0L = New Outlook.Application
Dim ONS As Outlook.Namespace
Set ONS = obJ0L.GetNamespace("MAPI")
Dim CAL_FOL As Outlook.Folder
Set CAL_FOL = ONS.GetDefaultFolder(olFolderCalendar).Folders("Excel")
Dim myapt As Outlook.AppointmentItem
Dim dCell As Range


'Maj måned starter her


For Each dCell In Range("D10:D40")
If dCell.Value = "dag" Then
If CheckAppointmentExists(dCell.Offset(0, -2) + TimeValue("06:45:00"), "Dagsvagt") = True Then
Else
Set myapt = CAL_FOL.Items.Add(olAppointmentItem)
With myapt
.Start = dCell.Offset(0, -2) + TimeValue("06:45:00")
.End = dCell.Offset(0, -2) + TimeValue("15:00:00")
.Subject = "Dagsvagt"
.Save
End With
End If
End If
Next dCell

For Each dCell In Range("D10:D40")
If dCell.Value = "overtid dag udb" Then
If CheckAppointmentExists(dCell.Offset(0, -2) + TimeValue("06:45:01"), "Overtid Dagsvagt") = True Then
Else
Set myapt = CAL_FOL.Items.Add(olAppointmentItem)
With myapt
.Start = dCell.Offset(0, -2) + TimeValue("06:45:00")
.End = dCell.Offset(0, -2) + TimeValue("15:00:00")
.Subject = "Overtid Dagsvagt"
.Save
End With
End If
End If
Next dCell

For Each dCell In Range("D10:D40")
If dCell.Value = "overtid dag afs" Then
If CheckAppointmentExists(dCell.Offset(0, -2) + TimeValue("06:45:01"), "Overtid Dagsvagt") = True Then
Else
Set myapt = CAL_FOL.Items.Add(olAppointmentItem)
With myapt
.Start = dCell.Offset(0, -2) + TimeValue("06:45:00")
.End = dCell.Offset(0, -2) + TimeValue("15:00:00")
.Subject = "Overtid Dagsvagt"
.Save
End With
End If
End If
Next dCell

For Each dCell In Range("D10:D40")
If dCell.Value = "aften" Then
If CheckAppointmentExists(dCell.Offset(0, -2) + TimeValue("14:45:00"), "Aftenvagt") = True Then
Else
Set myapt = CAL_FOL.Items.Add(olAppointmentItem)
With myapt
.Start = dCell.Offset(0, -2) + TimeValue("14:45:00")
.End = dCell.Offset(0, -2) + TimeValue("23:00:00")
.Subject = "Aftenvagt"
.Save
End With
End If
End If
Next dCell

For Each dCell In Range("D10:D40")
If dCell.Value = "overtid aft udb" Then
If CheckAppointmentExists(dCell.Offset(0, -2) + TimeValue("14:45:01"), "Overtid Aftenvagt") = True Then
Else
Set myapt = CAL_FOL.Items.Add(olAppointmentItem)
With myapt
.Start = dCell.Offset(0, -2) + TimeValue("14:45:00")
.End = dCell.Offset(0, -2) + TimeValue("23:00:00")
.Subject = "Overtid Aftenvagt"
.Save
End With
End If
End If
Next dCell

For Each dCell In Range("D10:D40")
If dCell.Value = "overtid aft afs" Then
If CheckAppointmentExists(dCell.Offset(0, -2) + TimeValue("14:45:01"), "Overtid Aftenvagt") = True Then
Else
Set myapt = CAL_FOL.Items.Add(olAppointmentItem)
With myapt
.Start = dCell.Offset(0, -2) + TimeValue("14:45:00")
.End = dCell.Offset(0, -2) + TimeValue("23:00:00")
.Subject = "Overtid Aftenvagt"
.Save
End With
End If
End If
Next dCell

For Each dCell In Range("D10:D40")
If dCell.Value = "nat" Then
If CheckAppointmentExists(dCell.Offset(0, -2) + TimeValue("22:45:00"), "Nattevagt") = True Then
Else
Set myapt = CAL_FOL.Items.Add(olAppointmentItem)
With myapt
.Start = dCell.Offset(0, -2) + TimeValue("22:45:00")
.End = dCell.Offset(1, -2) + TimeValue("07:00:00")
.Subject = "Nattevagt"
.Save
End With
End If
End If
Next dCell

For Each dCell In Range("D10:D40")
If dCell.Value = "overtid nat udb" Then
If CheckAppointmentExists(dCell.Offset(0, -2) + TimeValue("22:45:01"), "Overtid Nattevagt") = True Then
Else
Set myapt = CAL_FOL.Items.Add(olAppointmentItem)
With myapt
.Start = dCell.Offset(0, -2) + TimeValue("22:45:00")
.End = dCell.Offset(1, -2) + TimeValue("07:00:00")
.Subject = "Overtid Nattevagt"
.Save
End With
End If
End If
Next dCell

For Each dCell In Range("D10:D40")
If dCell.Value = "overtid nat afs" Then
If CheckAppointmentExists(dCell.Offset(0, -2) + TimeValue("22:45:01"), "Overtid Nattevagt") = True Then
Else
Set myapt = CAL_FOL.Items.Add(olAppointmentItem)
With myapt
.Start = dCell.Offset(0, -2) + TimeValue("22:45:00")
.End = dCell.Offset(1, -2) + TimeValue("07:00:00")
.Subject = "Overtid Nattevagt"
.Save
End With
End If
End If
Next dCell

For Each dCell In Range("D10:D40")
If dCell.Value = "support" Then
If CheckAppointmentExists(dCell.Offset(0, -2) + TimeValue("06:45:01"), "Support") = True Then
Else
Set myapt = CAL_FOL.Items.Add(olAppointmentItem)
With myapt
.Start = dCell.Offset(0, -2) + TimeValue("06:45:00")
.End = dCell.Offset(0, -2) + TimeValue("15:00:00")
.Subject = "Support"
.Save
End With
End If
End If
Next dCell

For Each dCell In Range("D10:D40")
If dCell.Value = "kursus" Then
If CheckAppointmentExists(dCell.Offset(0, -2) + TimeValue("06:45:02"), "Kursus") = True Then
Else
Set myapt = CAL_FOL.Items.Add(olAppointmentItem)
With myapt
.Start = dCell.Offset(0, -2) + TimeValue("06:45:00")
.End = dCell.Offset(0, -2) + TimeValue("15:00:00")
.Subject = "Kursus"
.Save
End With
End If
End If
Next dCell

For Each dCell In Range("D10:D40")
If dCell.Value = "fri" Then
If CheckAppointmentExists(dCell.Offset(0, -2) + TimeValue("00:00:01"), "Fri") = True Then
Else
Set myapt = CAL_FOL.Items.Add(olAppointmentItem)
With myapt
.Start = dCell.Offset(0, -2) + TimeValue("00:00:00")
.End = dCell.Offset(0, -2) + TimeValue("00:00:00")
.Subject = "Fri"
.Save
End With
End If
End If
Next dCell

For Each dCell In Range("D10:D40")
If dCell.Value = "ferie" Then
If CheckAppointmentExists(dCell.Offset(0, -2) + TimeValue("00:00:02"), "Ferie") = True Then
Else
Set myapt = CAL_FOL.Items.Add(olAppointmentItem)
With myapt
.Start = dCell.Offset(0, -2) + TimeValue("00:00:00")
.End = dCell.Offset(0, -2) + TimeValue("00:00:00")
.Subject = "Ferie"
.Save
End With
End If
End If
Next dCell

For Each dCell In Range("D10:D40")
If dCell.Value = "feriefri" Then
If CheckAppointmentExists(dCell.Offset(0, -2) + TimeValue("00:00:03"), "Feriefri") = True Then
Else
Set myapt = CAL_FOL.Items.Add(olAppointmentItem)
With myapt
.Start = dCell.Offset(0, -2) + TimeValue("00:00:00")
.End = dCell.Offset(0, -2) + TimeValue("00:00:00")
.Subject = "Feriefri"
.Save
End With
End If
End If
Next dCell

'Juni måned starter her

For Each dCell In Range("L10:L40")
If dCell.Value = "dag" Then
If CheckAppointmentExists(dCell.Offset(0, -2) + TimeValue("06:45:00"), "Dagsvagt") = True Then
Else
Set myapt = CAL_FOL.Items.Add(olAppointmentItem)
With myapt
.Start = dCell.Offset(0, -2) + TimeValue("06:45:00")
.End = dCell.Offset(0, -2) + TimeValue("15:00:00")
.Subject = "Dagsvagt"
.Save
End With
End If
End If
Next dCell

For Each dCell In Range("L10:L40")
If dCell.Value = "overtid dag udb" Then
If CheckAppointmentExists(dCell.Offset(0, -2) + TimeValue("06:45:01"), "Overtid Dagsvagt") = True Then
Else
Set myapt = CAL_FOL.Items.Add(olAppointmentItem)
With myapt
.Start = dCell.Offset(0, -2) + TimeValue("06:45:00")
.End = dCell.Offset(0, -2) + TimeValue("15:00:00")
.Subject = "Overtid Dagsvagt"
.Save
End With
End If
End If
Next dCell

For Each dCell In Range("L10:L40")
If dCell.Value = "overtid dag afs" Then
If CheckAppointmentExists(dCell.Offset(0, -2) + TimeValue("06:45:01"), "Overtid Dagsvagt") = True Then
Else
Set myapt = CAL_FOL.Items.Add(olAppointmentItem)
With myapt
.Start = dCell.Offset(0, -2) + TimeValue("06:45:00")
.End = dCell.Offset(0, -2) + TimeValue("15:00:00")
.Subject = "Overtid Dagsvagt"
.Save
End With
End If
End If
Next dCell

For Each dCell In Range("L10:L40")
If dCell.Value = "aften" Then
If CheckAppointmentExists(dCell.Offset(0, -2) + TimeValue("14:45:00"), "Aftenvagt") = True Then
Else
Set myapt = CAL_FOL.Items.Add(olAppointmentItem)
With myapt
.Start = dCell.Offset(0, -2) + TimeValue("14:45:00")
.End = dCell.Offset(0, -2) + TimeValue("23:00:00")
.Subject = "Aftenvagt"
.Save
End With
End If
End If
Next dCell

For Each dCell In Range("L10:L40")
If dCell.Value = "overtid aft udb" Then
If CheckAppointmentExists(dCell.Offset(0, -2) + TimeValue("14:45:01"), "Overtid Aftenvagt") = True Then
Else
Set myapt = CAL_FOL.Items.Add(olAppointmentItem)
With myapt
.Start = dCell.Offset(0, -2) + TimeValue("14:45:00")
.End = dCell.Offset(0, -2) + TimeValue("23:00:00")
.Subject = "Overtid Aftenvagt"
.Save
End With
End If
End If
Next dCell

For Each dCell In Range("L10:L40")
If dCell.Value = "overtid aft afs" Then
If CheckAppointmentExists(dCell.Offset(0, -2) + TimeValue("14:45:01"), "Overtid Aftenvagt") = True Then
Else
Set myapt = CAL_FOL.Items.Add(olAppointmentItem)
With myapt
.Start = dCell.Offset(0, -2) + TimeValue("14:45:00")
.End = dCell.Offset(0, -2) + TimeValue("23:00:00")
.Subject = "Overtid Aftenvagt"
.Save
End With
End If
End If
Next dCell

For Each dCell In Range("L10:L40")
If dCell.Value = "nat" Then
If CheckAppointmentExists(dCell.Offset(0, -2) + TimeValue("22:45:00"), "Nattevagt") = True Then
Else
Set myapt = CAL_FOL.Items.Add(olAppointmentItem)
With myapt
.Start = dCell.Offset(0, -2) + TimeValue("22:45:00")
.End = dCell.Offset(1, -2) + TimeValue("07:00:00")
.Subject = "Nattevagt"
.Save
End With
End If
End If
Next dCell

For Each dCell In Range("L10:L40")
If dCell.Value = "overtid nat udb" Then
If CheckAppointmentExists(dCell.Offset(0, -2) + TimeValue("22:45:01"), "Overtid Nattevagt") = True Then
Else
Set myapt = CAL_FOL.Items.Add(olAppointmentItem)
With myapt
.Start = dCell.Offset(0, -2) + TimeValue("22:45:00")
.End = dCell.Offset(1, -2) + TimeValue("07:00:00")
.Subject = "Overtid Nattevagt"
.Save
End With
End If
End If
Next dCell

For Each dCell In Range("L10:L40")
If dCell.Value = "overtid nat afs" Then
If CheckAppointmentExists(dCell.Offset(0, -2) + TimeValue("22:45:01"), "Overtid Nattevagt") = True Then
Else
Set myapt = CAL_FOL.Items.Add(olAppointmentItem)
With myapt
.Start = dCell.Offset(0, -2) + TimeValue("22:45:00")
.End = dCell.Offset(1, -2) + TimeValue("07:00:00")
.Subject = "Overtid Nattevagt"
.Save
End With
End If
End If
Next dCell

For Each dCell In Range("L10:L40")
If dCell.Value = "support" Then
If CheckAppointmentExists(dCell.Offset(0, -2) + TimeValue("06:45:01"), "Support") = True Then
Else
Set myapt = CAL_FOL.Items.Add(olAppointmentItem)
With myapt
.Start = dCell.Offset(0, -2) + TimeValue("06:45:00")
.End = dCell.Offset(0, -2) + TimeValue("15:00:00")
.Subject = "Support"
.Save
End With
End If
End If
Next dCell

For Each dCell In Range("L10:L40")
If dCell.Value = "kursus" Then
If CheckAppointmentExists(dCell.Offset(0, -2) + TimeValue("06:45:02"), "Kursus") = True Then
Else
Set myapt = CAL_FOL.Items.Add(olAppointmentItem)
With myapt
.Start = dCell.Offset(0, -2) + TimeValue("06:45:00")
.End = dCell.Offset(0, -2) + TimeValue("15:00:00")
.Subject = "Kursus"
.Save
End With
End If
End If
Next dCell

For Each dCell In Range("L10:L40")
If dCell.Value = "fri" Then
If CheckAppointmentExists(dCell.Offset(0, -2) + TimeValue("00:00:01"), "Fri") = True Then
Else
Set myapt = CAL_FOL.Items.Add(olAppointmentItem)
With myapt
.Start = dCell.Offset(0, -2) + TimeValue("00:00:00")
.End = dCell.Offset(0, -2) + TimeValue("00:00:00")
.Subject = "Fri"
.Save
End With
End If
End If
Next dCell

For Each dCell In Range("L10:L40")
If dCell.Value = "ferie" Then
If CheckAppointmentExists(dCell.Offset(0, -2) + TimeValue("00:00:02"), "Ferie") = True Then
Else
Set myapt = CAL_FOL.Items.Add(olAppointmentItem)
With myapt
.Start = dCell.Offset(0, -2) + TimeValue("00:00:00")
.End = dCell.Offset(0, -2) + TimeValue("00:00:00")
.Subject = "Ferie"
.Save
End With
End If
End If
Next dCell

For Each dCell In Range("L10:L40")
If dCell.Value = "feriefri" Then
If CheckAppointmentExists(dCell.Offset(0, -2) + TimeValue("00:00:03"), "Feriefri") = True Then
Else
Set myapt = CAL_FOL.Items.Add(olAppointmentItem)
With myapt
.Start = dCell.Offset(0, -2) + TimeValue("00:00:00")
.End = dCell.Offset(0, -2) + TimeValue("00:00:00")
.Subject = "Feriefri"
.Save
End With
End If
End If
Next dCell

'Juli måned starter her

For Each dCell In Range("T10:T40")
If dCell.Value = "dag" Then
If CheckAppointmentExists(dCell.Offset(0, -2) + TimeValue("06:45:00"), "Dagsvagt") = True Then
Else
Set myapt = CAL_FOL.Items.Add(olAppointmentItem)
With myapt
.Start = dCell.Offset(0, -2) + TimeValue("06:45:00")
.End = dCell.Offset(0, -2) + TimeValue("15:00:00")
.Subject = "Dagsvagt"
.Save
End With
End If
End If
Next dCell

For Each dCell In Range("T10:T40")
If dCell.Value = "overtid dag udb" Then
If CheckAppointmentExists(dCell.Offset(0, -2) + TimeValue("06:45:01"), "Overtid Dagsvagt") = True Then
Else
Set myapt = CAL_FOL.Items.Add(olAppointmentItem)
With myapt
.Start = dCell.Offset(0, -2) + TimeValue("06:45:00")
.End = dCell.Offset(0, -2) + TimeValue("15:00:00")
.Subject = "Overtid Dagsvagt"
.Save
End With
End If
End If
Next dCell

For Each dCell In Range("T10:T40")
If dCell.Value = "overtid dag afs" Then
If CheckAppointmentExists(dCell.Offset(0, -2) + TimeValue("06:45:01"), "Overtid Dagsvagt") = True Then
Else
Set myapt = CAL_FOL.Items.Add(olAppointmentItem)
With myapt
.Start = dCell.Offset(0, -2) + TimeValue("06:45:00")
.End = dCell.Offset(0, -2) + TimeValue("15:00:00")
.Subject = "Overtid Dagsvagt"
.Save
End With
End If
End If
Next dCell

For Each dCell In Range("T10:T40")
If dCell.Value = "aften" Then
If CheckAppointmentExists(dCell.Offset(0, -2) + TimeValue("14:45:00"), "Aftenvagt") = True Then
Else
Set myapt = CAL_FOL.Items.Add(olAppointmentItem)
With myapt
.Start = dCell.Offset(0, -2) + TimeValue("14:45:00")
.End = dCell.Offset(0, -2) + TimeValue("23:00:00")
.Subject = "Aftenvagt"
.Save
End With
End If
End If
Next dCell

For Each dCell In Range("T10:T40")
If dCell.Value = "overtid aft udb" Then
If CheckAppointmentExists(dCell.Offset(0, -2) + TimeValue("14:45:01"), "Overtid Aftenvagt") = True Then
Else
Set myapt = CAL_FOL.Items.Add(olAppointmentItem)
With myapt
.Start = dCell.Offset(0, -2) + TimeValue("14:45:00")
.End = dCell.Offset(0, -2) + TimeValue("23:00:00")
.Subject = "Overtid Aftenvagt"
.Save
End With
End If
End If
Next dCell

For Each dCell In Range("T10:T40")
If dCell.Value = "overtid aft afs" Then
If CheckAppointmentExists(dCell.Offset(0, -2) + TimeValue("14:45:01"), "Overtid Aftenvagt") = True Then
Else
Set myapt = CAL_FOL.Items.Add(olAppointmentItem)
With myapt
.Start = dCell.Offset(0, -2) + TimeValue("14:45:00")
.End = dCell.Offset(0, -2) + TimeValue("23:00:00")
.Subject = "Overtid Aftenvagt"
.Save
End With
End If
End If
Next dCell

For Each dCell In Range("T10:T40")
If dCell.Value = "nat" Then
If CheckAppointmentExists(dCell.Offset(0, -2) + TimeValue("22:45:00"), "Nattevagt") = True Then
Else
Set myapt = CAL_FOL.Items.Add(olAppointmentItem)
With myapt
.Start = dCell.Offset(0, -2) + TimeValue("22:45:00")
.End = dCell.Offset(1, -2) + TimeValue("07:00:00")
.Subject = "Nattevagt"
.Save
End With
End If
End If
Next dCell

For Each dCell In Range("T10:T40")
If dCell.Value = "overtid nat udb" Then
If CheckAppointmentExists(dCell.Offset(0, -2) + TimeValue("22:45:01"), "Overtid Nattevagt") = True Then
Else
Set myapt = CAL_FOL.Items.Add(olAppointmentItem)
With myapt
.Start = dCell.Offset(0, -2) + TimeValue("22:45:00")
.End = dCell.Offset(1, -2) + TimeValue("07:00:00")
.Subject = "Overtid Nattevagt"
.Save
End With
End If
End If
Next dCell

For Each dCell In Range("T10:T40")
If dCell.Value = "overtid nat afs" Then
If CheckAppointmentExists(dCell.Offset(0, -2) + TimeValue("22:45:01"), "Overtid Nattevagt") = True Then
Else
Set myapt = CAL_FOL.Items.Add(olAppointmentItem)
With myapt
.Start = dCell.Offset(0, -2) + TimeValue("22:45:00")
.End = dCell.Offset(1, -2) + TimeValue("07:00:00")
.Subject = "Overtid Nattevagt"
.Save
End With
End If
End If
Next dCell

For Each dCell In Range("T10:T40")
If dCell.Value = "support" Then
If CheckAppointmentExists(dCell.Offset(0, -2) + TimeValue("06:45:01"), "Support") = True Then
Else
Set myapt = CAL_FOL.Items.Add(olAppointmentItem)
With myapt
.Start = dCell.Offset(0, -2) + TimeValue("06:45:00")
.End = dCell.Offset(0, -2) + TimeValue("15:00:00")
.Subject = "Support"
.Save
End With
End If
End If
Next dCell

For Each dCell In Range("T10:T40")
If dCell.Value = "kursus" Then
If CheckAppointmentExists(dCell.Offset(0, -2) + TimeValue("06:45:02"), "Kursus") = True Then
Else
Set myapt = CAL_FOL.Items.Add(olAppointmentItem)
With myapt
.Start = dCell.Offset(0, -2) + TimeValue("06:45:00")
.End = dCell.Offset(0, -2) + TimeValue("15:00:00")
.Subject = "Kursus"
.Save
End With
End If
End If
Next dCell

For Each dCell In Range("T10:T40")
If dCell.Value = "fri" Then
If CheckAppointmentExists(dCell.Offset(0, -2) + TimeValue("00:00:01"), "Fri") = True Then
Else
Set myapt = CAL_FOL.Items.Add(olAppointmentItem)
With myapt
.Start = dCell.Offset(0, -2) + TimeValue("00:00:00")
.End = dCell.Offset(0, -2) + TimeValue("00:00:00")
.Subject = "Fri"
.Save
End With
End If
End If
Next dCell

For Each dCell In Range("T10:T40")
If dCell.Value = "ferie" Then
If CheckAppointmentExists(dCell.Offset(0, -2) + TimeValue("00:00:02"), "Ferie") = True Then
Else
Set myapt = CAL_FOL.Items.Add(olAppointmentItem)
With myapt
.Start = dCell.Offset(0, -2) + TimeValue("00:00:00")
.End = dCell.Offset(0, -2) + TimeValue("00:00:00")
.Subject = "Ferie"
.Save
End With
End If
End If
Next dCell

For Each dCell In Range("T10:T40")
If dCell.Value = "feriefri" Then
If CheckAppointmentExists(dCell.Offset(0, -2) + TimeValue("00:00:03"), "Feriefri") = True Then
Else
Set myapt = CAL_FOL.Items.Add(olAppointmentItem)
With myapt
.Start = dCell.Offset(0, -2) + TimeValue("00:00:00")
.End = dCell.Offset(0, -2) + TimeValue("00:00:00")
.Subject = "Feriefri"
.Save
End With
End If
End If
Next dCell

'August starter her

For Each dCell In Range("D49:D79")
If dCell.Value = "dag" Then
If CheckAppointmentExists(dCell.Offset(0, -2) + TimeValue("06:45:00"), "Dagsvagt") = True Then
Else
Set myapt = CAL_FOL.Items.Add(olAppointmentItem)
With myapt
.Start = dCell.Offset(0, -2) + TimeValue("06:45:00")
.End = dCell.Offset(0, -2) + TimeValue("15:00:00")
.Subject = "Dagsvagt"
.Save
End With
End If
End If
Next dCell

For Each dCell In Range("D49:D79")
If dCell.Value = "overtid dag udb" Then
If CheckAppointmentExists(dCell.Offset(0, -2) + TimeValue("06:45:01"), "Overtid Dagsvagt") = True Then
Else
Set myapt = CAL_FOL.Items.Add(olAppointmentItem)
With myapt
.Start = dCell.Offset(0, -2) + TimeValue("06:45:00")
.End = dCell.Offset(0, -2) + TimeValue("15:00:00")
.Subject = "Overtid Dagsvagt"
.Save
End With
End If
End If
Next dCell

For Each dCell In Range("D49:D79")
If dCell.Value = "overtid dag afs" Then
If CheckAppointmentExists(dCell.Offset(0, -2) + TimeValue("06:45:01"), "Overtid Dagsvagt") = True Then
Else
Set myapt = CAL_FOL.Items.Add(olAppointmentItem)
With myapt
.Start = dCell.Offset(0, -2) + TimeValue("06:45:00")
.End = dCell.Offset(0, -2) + TimeValue("15:00:00")
.Subject = "Overtid Dagsvagt"
.Save
End With
End If
End If
Next dCell

For Each dCell In Range("D49:D79")
If dCell.Value = "aften" Then
If CheckAppointmentExists(dCell.Offset(0, -2) + TimeValue("14:45:00"), "Aftenvagt") = True Then
Else
Set myapt = CAL_FOL.Items.Add(olAppointmentItem)
With myapt
.Start = dCell.Offset(0, -2) + TimeValue("14:45:00")
.End = dCell.Offset(0, -2) + TimeValue("23:00:00")
.Subject = "Aftenvagt"
.Save
End With
End If
End If
Next dCell

For Each dCell In Range("D49:D79")
If dCell.Value = "overtid aft udb" Then
If CheckAppointmentExists(dCell.Offset(0, -2) + TimeValue("14:45:01"), "Overtid Aftenvagt") = True Then
Else
Set myapt = CAL_FOL.Items.Add(olAppointmentItem)
With myapt
.Start = dCell.Offset(0, -2) + TimeValue("14:45:00")
.End = dCell.Offset(0, -2) + TimeValue("23:00:00")
.Subject = "Overtid Aftenvagt"
.Save
End With
End If
End If
Next dCell

For Each dCell In Range("D49:D79")
If dCell.Value = "overtid aft afs" Then
If CheckAppointmentExists(dCell.Offset(0, -2) + TimeValue("14:45:01"), "Overtid Aftenvagt") = True Then
Else
Set myapt = CAL_FOL.Items.Add(olAppointmentItem)
With myapt
.Start = dCell.Offset(0, -2) + TimeValue("14:45:00")
.End = dCell.Offset(0, -2) + TimeValue("23:00:00")
.Subject = "Overtid Aftenvagt"
.Save
End With
End If
End If
Next dCell

For Each dCell In Range("D49:D79")
If dCell.Value = "nat" Then
If CheckAppointmentExists(dCell.Offset(0, -2) + TimeValue("22:45:00"), "Nattevagt") = True Then
Else
Set myapt = CAL_FOL.Items.Add(olAppointmentItem)
With myapt
.Start = dCell.Offset(0, -2) + TimeValue("22:45:00")
.End = dCell.Offset(1, -2) + TimeValue("07:00:00")
.Subject = "Nattevagt"
.Save
End With
End If
End If
Next dCell

For Each dCell In Range("D49:D79")
If dCell.Value = "overtid nat udb" Then
If CheckAppointmentExists(dCell.Offset(0, -2) + TimeValue("22:45:01"), "Overtid Nattevagt") = True Then
Else
Set myapt = CAL_FOL.Items.Add(olAppointmentItem)
With myapt
.Start = dCell.Offset(0, -2) + TimeValue("22:45:00")
.End = dCell.Offset(1, -2) + TimeValue("07:00:00")
.Subject = "Overtid Nattevagt"
.Save
End With
End If
End If
Next dCell

For Each dCell In Range("D49:D79")
If dCell.Value = "overtid nat afs" Then
If CheckAppointmentExists(dCell.Offset(0, -2) + TimeValue("22:45:01"), "Overtid Nattevagt") = True Then
Else
Set myapt = CAL_FOL.Items.Add(olAppointmentItem)
With myapt
.Start = dCell.Offset(0, -2) + TimeValue("22:45:00")
.End = dCell.Offset(1, -2) + TimeValue("07:00:00")
.Subject = "Overtid Nattevagt"
.Save
End With
End If
End If
Next dCell

For Each dCell In Range("D49:D79")
If dCell.Value = "support" Then
If CheckAppointmentExists(dCell.Offset(0, -2) + TimeValue("06:45:01"), "Support") = True Then
Else
Set myapt = CAL_FOL.Items.Add(olAppointmentItem)
With myapt
.Start = dCell.Offset(0, -2) + TimeValue("06:45:00")
.End = dCell.Offset(0, -2) + TimeValue("15:00:00")
.Subject = "Support"
.Save
End With
End If
End If
Next dCell

For Each dCell In Range("D49:D79")
If dCell.Value = "kursus" Then
If CheckAppointmentExists(dCell.Offset(0, -2) + TimeValue("06:45:02"), "Kursus") = True Then
Else
Set myapt = CAL_FOL.Items.Add(olAppointmentItem)
With myapt
.Start = dCell.Offset(0, -2) + TimeValue("06:45:00")
.End = dCell.Offset(0, -2) + TimeValue("15:00:00")
.Subject = "Kursus"
.Save
End With
End If
End If
Next dCell

For Each dCell In Range("D49:D79")
If dCell.Value = "fri" Then
If CheckAppointmentExists(dCell.Offset(0, -2) + TimeValue("00:00:01"), "Fri") = True Then
Else
Set myapt = CAL_FOL.Items.Add(olAppointmentItem)
With myapt
.Start = dCell.Offset(0, -2) + TimeValue("00:00:00")
.End = dCell.Offset(0, -2) + TimeValue("00:00:00")
.Subject = "Fri"
.Save
End With
End If
End If
Next dCell

For Each dCell In Range("D49:D79")
If dCell.Value = "ferie" Then
If CheckAppointmentExists(dCell.Offset(0, -2) + TimeValue("00:00:02"), "Ferie") = True Then
Else
Set myapt = CAL_FOL.Items.Add(olAppointmentItem)
With myapt
.Start = dCell.Offset(0, -2) + TimeValue("00:00:00")
.End = dCell.Offset(0, -2) + TimeValue("00:00:00")
.Subject = "Ferie"
.Save
End With
End If
End If
Next dCell

For Each dCell In Range("D49:D79")
If dCell.Value = "feriefri" Then
If CheckAppointmentExists(dCell.Offset(0, -2) + TimeValue("00:00:03"), "Feriefri") = True Then
Else
Set myapt = CAL_FOL.Items.Add(olAppointmentItem)
With myapt
.Start = dCell.Offset(0, -2) + TimeValue("00:00:00")
.End = dCell.Offset(0, -2) + TimeValue("00:00:00")
.Subject = "Feriefri"
.Save
End With
End If
End If
Next dCell

End Sub
 
Upvote 0
Re: VBA - Connect excel with Outlook problem?!

Ok I got it: the start time in checkappointmentexists has to be exactly the same (to the second) than what the macro wrote in outlook, otherwise starting date is different and he rewrites it.

So basically, you need to match those:

Code: 
For Each dCell In Range("D10:D40")
        If dCell.Value = "overtid dag afs" Then
            If CheckAppointmentExists(dCell.Offset(0, -2) + TimeValue("[COLOR=#ff0000]06:45:01[/COLOR]"), "Overtid Dagsvagt") = True Then
              Else
               Set myapt = CAL_FOL.Items.Add(olAppointmentItem)
                   With myapt
                           .Start = dCell.Offset(0, -2) + TimeValue("[COLOR=#ff0000]06:45:00[/COLOR]")
                           .End = dCell.Offset(0, -2) + TimeValue("15:00:00")
                           .Subject = "Overtid Dagsvagt"
                       .Save
                   End With
            End If
        End If
    Next dCell[/COD

Note: I stoped having such long macros when I learned how to loop. In this case, I would have set a table comparing if dcell=dag, subject = dagvast, if dcell = …,subject = … or there is something very pretty in VBA called "Case". 
basically something like 
[CODE][LEFT][COLOR=#222222][FONT=Verdana]Select Case ...[/FONT][/COLOR]
[COLOR=#222222][FONT=Verdana]case "dag" [/FONT][/COLOR]
[COLOR=#222222][FONT=Verdana]       Subject =  "dagvast"[/FONT][/COLOR]
[COLOR=#222222][FONT=Verdana]       StartTime = [/FONT][/COLOR][COLOR=#222222][FONT=Verdana]"[/FONT][/COLOR][/LEFT][COLOR=#ff0000][LEFT][COLOR=#FF0000][FONT=Verdana]06:45:00[/FONT][/COLOR][/LEFT][/COLOR][LEFT][COLOR=#222222][FONT=Verdana]"[/FONT][/COLOR]
[COLOR=#222222][FONT=Verdana]Case "ferie"[/FONT][/COLOR][/LEFT][
and so on/CODE]
I would then have made an array of ranges for dcell once (all the columns D, T where you look for) y naming them in excel (formula tab, define name) and run it once.
 
Last edited:
Upvote 0
Re: VBA - Connect excel with Outlook problem?!

Ahh ofc...got blind from staring at it for too long.

Nice to know! I will definitly look into that since it takes two minutes to run the macro..
 
Upvote 0
Re: VBA - Connect excel with Outlook problem?!

I've been looking at that case logic a bit. And it would be ALOT easier. I get the idea behind it but could you make an example of how to do this for just a "Dagsvagt"? and the array
 
Upvote 0
You must log in or register to reply here.

Similar threads

W
  • Solved
Count hours on specific days and time, return value in decimal hours
2
Replies
17
Views
966
BSALV
BSALV

Forum statistics

Threads
1,214,581
Messages
6,120,368
Members
448,957
Latest member
BatCoder

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top