# VBA - Connect excel with Outlook



## Phil810 (Sep 18, 2018)

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:


```
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 timerTimerOverArbejde01-majtirsdagdag8,2502-majonsdagaften8,9803-majtorsdagaften816,9804-majfredagaften8,9805-majlørdagaften8,9806-majsøndagaften8,9807-majmandagaften8,9808-majtirsdagaften8,9809-majonsdagovertid aft udb17,9610-majtorsdagaften8,9811-majfredag12-majlørdag13-majsøndag14-majmandag15-majtirsdag16-majonsdag4,54,517-majtorsdagdag19,2518-majfredagdag8,2519-majlørdag20-majsøndag21-majmandag22-majtirsdagdag1,259,523-majonsdagdag1,751024-majtorsdag25-majfredagaften8,9826-majlørdagaften8,2517,2327-majsøndagaften8,2517,2328-majmandag29-majtirsdag30-majonsdag31-majtorsdag

<tbody>

</tbody>

I hope someone can help me


----------



## Norie (Sep 18, 2018)

*Re: VBA - Connect excel with Outlook problem?!*

Where do you get the error?


----------



## Kamolga (Sep 18, 2018)

*Re: VBA - Connect excel with Outlook problem?!*

Hi,

From my old souvenir, I had an error message when connecting 2 office applications if in VBA, I was not going to tools/reference and click outlook project library.

Else you might have an issue with a string=range (and it can not be multiple cells) in 

```
[LEFT][COLOR=#333333][FONT=monospace]If MyCheck = MyRange Then
[/FONT][/COLOR][/LEFT]
```

Oh and basically if you want to look for a cell called "dag" in a range (MyRange) of multiple cells, you need to do a loop (having a cell that will be compared to the value, do something if it equals, and go to the next one). If you want to do something if one the cell equals dag and leave the loop, simply type 
Goto OutofLoop before "end if" and OutofLoop: after "next dCell". That would be "if condition is met once" equivalent while the code below is "every time a cell meets the condition"


```
[LEFT][COLOR=#333333][FONT=monospace]MyCheck = "dag"
[/FONT][/COLOR][/LEFT]
[COLOR=#0000cd][LEFT]Dim dCell as Range[/LEFT]
[/COLOR][LEFT][COLOR=#333333][FONT=monospace]
MyRange = Range("D10:D17")
MyRange2 = Range("B10:B17")

      F[/FONT][/COLOR][COLOR=#0000cd]or each dCell in MyRange[/COLOR]
[COLOR=#333333][FONT=monospace]
        If [/FONT][/COLOR][COLOR=#0000cd]dCell.value = MyCheck [/COLOR][COLOR=#333333][FONT=monospace]Then
[/FONT][/COLOR]
[COLOR=#333333][FONT=monospace]        .Start = MyRange2 + TimeValue("06:45:00")

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

        .Subject = "Dagsvagt"
    End If[/FONT][/COLOR][/LEFT]
[COLOR=#0000cd]Next dCell[/COLOR]
```

Hope it helps


----------



## Phil810 (Sep 18, 2018)

*Re: VBA - Connect excel with Outlook problem?!*

Hi Kamolga,

Thanks Ive just tried your code, and now it says that I need an object as error


----------



## Kamolga (Sep 18, 2018)

*Re: VBA - Connect excel with Outlook problem?!*

I think you have the same issue with Range2, you need to define a specific cell.

If I understand what you try to do, when the condition is met in colomn D "MyRange" you would like to take the value in MyRange2 (column B).

I would not define Range2 but when the value dag is met with dCell in MyRange, you can use 
	
	
	
	
	
	



```
dCell.offset(0,-2)
```
 to refer to the cell 0 line below, 2 columns to the left...so the first time 01-maj ​and17-maj ​​the second,...

Trye to change 
	
	
	
	
	
	



```
[LEFT][COLOR=#333333][FONT=monospace]Start = MyRange2 + TimeValue("06:45:00")
[/FONT][/COLOR][/LEFT]
```
 by 
	
	
	
	
	
	



```
[LEFT][COLOR=#333333][FONT=monospace]Start = [COLOR=#222222][FONT=Verdana]dCell.offset(0,-2)[/FONT][/COLOR] + TimeValue("06:45:00")[/FONT][/COLOR][/LEFT]
```
 and same with end


----------



## Phil810 (Sep 18, 2018)

*Re: VBA - Connect excel with Outlook problem?!*

What I would like to do is that if the cell equals "dag" then it should look at the date in column B which is B10:B40 and then use this date to set the appointment in outlook. I dont know if this is the correct way or even possible this way. And it still says object required.


----------



## Kamolga (Sep 18, 2018)

*Re: VBA - Connect excel with Outlook problem?!*

ok, I did paste your data from 01-maj in B10 and all the data until D40. I then replaced 01-maj by 01/05/2018,set them up as short date format and dragged it down to have all date formed in column B (not general).

I then opened VBA, clicked on tools, then reference and put a little "v" in Microsoft Outlook 16.0 Object Library". This step in mandatory to avoid errors.

Now when I use this macro, 


```
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
    For Each dCell In Range("D10:D40")
        If dCell.Value = "dag" Then
            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
    Next dCell
End Sub
```

I got 5 appointments (1 may, 17 May, 18 May, 22 May, and 23 MAy) named "Dagsvagt" in my outlook calendar. No object required message with this one


----------



## Kamolga (Sep 18, 2018)

*Re: VBA - Connect excel with Outlook problem?!*

Of course you need to be on the right sheet when you launch it and outlook can be close. You can download my test file here (https://1drv.ms/x/s!AvmGsNl7aaaAgtMTKY8klaAWIQOvow with the 3 dots top right) if needed


----------



## Phil810 (Sep 19, 2018)

*Re: VBA - Connect excel with Outlook problem?!*

It works perfectly! Thanks alot Kamolga! The only problem now, is that it creates dublicates.. Ive tried to sort it out in the IF sentence with "dag" and then adding AND NOT appointment exists =true sort of thing but to no avail. Do you have any tips?


----------



## Kamolga (Sep 19, 2018)

*Re: VBA - Connect excel with Outlook problem?!*

Hi,

I updated the file, so you can download it. Basically I added a function "checkappointmentexist" (that returns true if the start date and time is the same and subject is identical). You can post it in the same module


```
[LEFT][COLOR=#222222][FONT=Verdana]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)
  CheckAppointment = False
  For Each oObject In oFolder.Items
    If oObject.Class = olAppointment Then
      Set oApptItem = oObject
      If oApptItem.Start = argCheckDate Then
        CheckAppointment = True
      End If
    End If
  Next oObject
  Set oApp = Nothing
  Set oNameSpace = Nothing
  Set oApptItem = Nothing
  Set oFolder = Nothing
  Set oObject = Nothing
End Function
[/FONT][/COLOR][/LEFT]
```
Then the macro is aupdated with "if checkappointmentexist = true do nothing else add the appointment" and that works for me, he adds only the one I deleted after I runned the macro and no more duplicates 
​

```
[LEFT][COLOR=#222222][FONT=Verdana]Sub OpdaterOutlook()[/FONT][/COLOR]
[COLOR=#222222][FONT=Verdana]Dim obJ0L As Object[/FONT][/COLOR]
[COLOR=#222222][FONT=Verdana]Set obJ0L = CreateObject("Outlook.Application")[/FONT][/COLOR]
[COLOR=#222222][FONT=Verdana]Set obJ0L = New Outlook.Application[/FONT][/COLOR]
[COLOR=#222222][FONT=Verdana]Dim ONS As Outlook.Namespace[/FONT][/COLOR]
[COLOR=#222222][FONT=Verdana]Set ONS = obJ0L.GetNamespace("MAPI")[/FONT][/COLOR]
[COLOR=#222222][FONT=Verdana]Dim CAL_FOL As Outlook.Folder[/FONT][/COLOR]
[COLOR=#222222][FONT=Verdana]Set CAL_FOL = ONS.GetDefaultFolder(olFolderCalendar)[/FONT][/COLOR]
[COLOR=#222222][FONT=Verdana]Dim myapt As Outlook.AppointmentItem[/FONT][/COLOR]
[COLOR=#222222][FONT=Verdana]Dim dCell As Range[/FONT][/COLOR]
[COLOR=#222222][FONT=Verdana]    For Each dCell In Range("D10:D40")[/FONT][/COLOR]
[COLOR=#222222][FONT=Verdana]        If dCell.Value = "dag" Then[/FONT][/COLOR]
[COLOR=#222222][FONT=Verdana]            If CheckAppointmentExists(dCell.Offset(0, -2) + TimeValue("06:45:00"), "Dagsvagt") = True Then[/FONT][/COLOR]
[COLOR=#222222][FONT=Verdana]              Else[/FONT][/COLOR]
[COLOR=#222222][FONT=Verdana]               Set myapt = CAL_FOL.Items.Add(olAppointmentItem)[/FONT][/COLOR]
[COLOR=#222222][FONT=Verdana]                   With myapt[/FONT][/COLOR]
[COLOR=#222222][FONT=Verdana]                           .Start = dCell.Offset(0, -2) + TimeValue("06:45:00")[/FONT][/COLOR]
[COLOR=#222222][FONT=Verdana]                           .End = dCell.Offset(0, -2) + TimeValue("15:00:00")[/FONT][/COLOR]
[COLOR=#222222][FONT=Verdana]                           .Subject = "Dagsvagt"[/FONT][/COLOR]
[COLOR=#222222][FONT=Verdana]                       .Save[/FONT][/COLOR]
[COLOR=#222222][FONT=Verdana]                   End With[/FONT][/COLOR]
[COLOR=#222222][FONT=Verdana]            End If[/FONT][/COLOR]
[COLOR=#222222][FONT=Verdana]        End If[/FONT][/COLOR]
[COLOR=#222222][FONT=Verdana]    Next dCell[/FONT][/COLOR]
[COLOR=#222222][FONT=Verdana]End Sub
[/FONT][/COLOR][/LEFT]
```
​


----------



## Phil810 (Sep 18, 2018)

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:


```
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 timerTimerOverArbejde01-majtirsdagdag8,2502-majonsdagaften8,9803-majtorsdagaften816,9804-majfredagaften8,9805-majlørdagaften8,9806-majsøndagaften8,9807-majmandagaften8,9808-majtirsdagaften8,9809-majonsdagovertid aft udb17,9610-majtorsdagaften8,9811-majfredag12-majlørdag13-majsøndag14-majmandag15-majtirsdag16-majonsdag4,54,517-majtorsdagdag19,2518-majfredagdag8,2519-majlørdag20-majsøndag21-majmandag22-majtirsdagdag1,259,523-majonsdagdag1,751024-majtorsdag25-majfredagaften8,9826-majlørdagaften8,2517,2327-majsøndagaften8,2517,2328-majmandag29-majtirsdag30-majonsdag31-majtorsdag

<tbody>

</tbody>

I hope someone can help me


----------



## Kamolga (Sep 19, 2018)

*Re: VBA - Connect excel with Outlook problem?!*

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


```
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
```


----------



## Phil810 (Sep 22, 2018)

*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


----------



## Kamolga (Sep 23, 2018)

*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. 

```
Public AppOndaySubj As String
```
 on top of the module and 

```
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

```
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


----------



## Phil810 (Sep 24, 2018)

*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?


----------



## Phil810 (Sep 24, 2018)

*Re: VBA - Connect excel with Outlook problem?!*

So to sum up - it has started dublicating again..


----------



## Kamolga (Sep 25, 2018)

*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 
	
	
	
	
	
	



```
[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


```
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
```


----------



## Phil810 (Sep 25, 2018)

*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


----------



## Kamolga (Sep 25, 2018)

*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:


```
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.
```


----------



## Phil810 (Sep 25, 2018)

*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..


----------



## Phil810 (Sep 25, 2018)

*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


----------



## Phil810 (Sep 18, 2018)

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:


```
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 timerTimerOverArbejde01-majtirsdagdag8,2502-majonsdagaften8,9803-majtorsdagaften816,9804-majfredagaften8,9805-majlørdagaften8,9806-majsøndagaften8,9807-majmandagaften8,9808-majtirsdagaften8,9809-majonsdagovertid aft udb17,9610-majtorsdagaften8,9811-majfredag12-majlørdag13-majsøndag14-majmandag15-majtirsdag16-majonsdag4,54,517-majtorsdagdag19,2518-majfredagdag8,2519-majlørdag20-majsøndag21-majmandag22-majtirsdagdag1,259,523-majonsdagdag1,751024-majtorsdag25-majfredagaften8,9826-majlørdagaften8,2517,2327-majsøndagaften8,2517,2328-majmandag29-majtirsdag30-majonsdag31-majtorsdag

<tbody>

</tbody>

I hope someone can help me


----------



## Kamolga (Sep 25, 2018)

*Re: VBA - Connect excel with Outlook problem?!*

Basically I chose the easy option: union of the ranges and withing the loop, the different cases. 
Both functions are used here (if appointment exist, no entry and if there is another appointment, ask if you want to put or not but you could change that part of the code)


```
Sub ToOutlook()
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
'Declare a subject, start time and end time for the appointments
Dim Subj As String
Dim STime As String
Dim ETime As String
 'Go through the cells with subject in combined range
    For Each dCell In Union([COLOR=#ff0000]Range("D10:D40"), Range("L10:L40"), Range("T10:T40"), Range("D49:T49")[/COLOR])
      'Identify subjct, start and end times based on dCell
     [COLOR=#008000] Select Case dCell.Value
          Case "dag"
               Subj = "Dagsvagt"
               STime = "06:45:00"
               ETime = "15:00:00"
          Case "overtid dag udb"
               Subj = "Overtid Dagsvagt"
               STime = "06:45:00"
               ETime = "15:00:00"
          Case "aften"
               Subj = "Aftenvagt"
               STime = "14:45:00"
               ETime = "23:00:00"
          Case "overtid aft udb"
               Subj = "Overtid Aftenvagt"
               STime = "14:45:00"
               ETime = "23:00:00"
          Case "overtid nat afs"
               Subj = "Overtid Aftenvagt"
               STime = "22:45:00"
               ETime = "07:00:00"
          Case "support"
               Subj = "Support"
               STime = "06:45:00"
               ETime = "15:00:00"
          Case "kursus"
               Subj = "Kursus"
               STime = "06:45:00"
               ETime = "15:00:00"
          Case "fri"
               Subj = "Fri"
               STime = "00:00:00"
               ETime = "00:00:00"
          Case "ferie"
               Subj = "Ferie"
               STime = "00:00:00"
               ETime = "00:00:00"
          Case "feriefri"
               Subj = "Feriefri"
               STime = "00:00:00"
               ETime = "00:00:00"
           Case Else
            GoTo NoEntry
      End Select[/COLOR]
          'if there is an appointment with same starting time and subject
            If CheckAppointmentExists(dCell.Offset(0, -2) + TimeValue(STime), Subj) = 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 " & Subj & " item from " & STime & " until " & ETime & " 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(STime)
                           .End = dCell.Offset(0, -2) + TimeValue(ETime)
                           .Subject = Subj
                       .Save
                   End With
               End If
NoEntry:
    Next dCell
End Sub
```

Note: it is always good to comment your macros. There is no way you would remember it in 2 years if you had to come back on it....and it is gold for others as well. I basically used this skeleton to export MSProject tasks to outlook, the comments helped me already through the evolution of this project. Much easier to get into it from one day to another as well.


----------



## Phil810 (Sep 26, 2018)

*Re: VBA - Connect excel with Outlook problem?!*

Nice it works good except the fact that I cant seem to add more ranges than the ones you've already entered? I cant extend the union with (Range("D49:D79"), Range("L49:L79"), Range("T49:79") and so on..

And also I would like the AppOnDay only to ask the question if there is an already existing appointment NOT equal to the on thats read from the excel file..I've tried to modify it by simple putting an NOT after dCell(...) and entering an Timevalue other than the one its looking at, but it does not work...Any pointers?


----------



## Kamolga (Sep 26, 2018)

*Re: VBA - Connect excel with Outlook problem?!*



Phil810 said:


> Nice it works good except the fact that I cant seem to add more ranges than the ones you've already entered? I cant extend the union with (Range("D49:D79"), Range("L49:L79"), Range("T49:79") and so on..



You can go up to 30 ranges, if more, no problem make a second range and a union of both, so I guess you simply made a spelling mistake, like in your question Range("T49:T79")​

```
[LEFT][COLOR=#333333][FONT=Verdana]And also I would like the AppOnDay only to ask the question if there is an already existing appointment NOT equal to the on thats read from the excel file.[/FONT][/COLOR][/LEFT]
```
 This is the case, if the appointment is the same, it is a duplicate and is handled before (by going directly to no entry). I made the test in the file (that you can still downmload from the link) and it only asked as the subject were different. In the question he says "you have an appointment with subject xxx, do you want to add an appointment yyyy from ?? hour until ?? hour? xxx will never be the same of yyyy unless they don't start on same time

Below the code with extra range that are included:


```
Public AppOndaySubj As String
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
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
Sub ToOutlook()
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
'Declare a subject, start time and end time for the appointments
Dim Subj As String
Dim STime As String
Dim ETime As String
 'Go through the cells with subject in combined range
    For Each dCell In Union(Range("D10:D40"), Range("L10:L40"), Range("T10:T40"), Range("D49:T49"), Range("L49:L79"), Range("T49:T79"))
      'Identify subjct, start and end times based on dCell
      Select Case dCell.Value
          Case "dag"
               Subj = "Dagsvagt"
               STime = "06:45:00"
               ETime = "15:00:00"
          Case "overtid dag udb"
               Subj = "Overtid Dagsvagt"
               STime = "06:45:00"
               ETime = "15:00:00"
          Case "aften"
               Subj = "Aftenvagt"
               STime = "14:45:00"
               ETime = "23:00:00"
          Case "overtid aft udb"
               Subj = "Overtid Aftenvagt"
               STime = "14:45:00"
               ETime = "23:00:00"
          Case "overtid nat afs"
               Subj = "Overtid Aftenvagt"
               STime = "22:45:00"
               ETime = "07:00:00"
          Case "support"
               Subj = "Support"
               STime = "06:45:00"
               ETime = "15:00:00"
          Case "kursus"
               Subj = "Kursus"
               STime = "06:45:00"
               ETime = "15:00:00"
          Case "fri"
               Subj = "Fri"
               STime = "00:00:00"
               ETime = "00:00:00"
          Case "ferie"
               Subj = "Ferie"
               STime = "00:00:00"
               ETime = "00:00:00"
          Case "feriefri"
               Subj = "Feriefri"
               STime = "00:00:00"
               ETime = "00:00:00"
           Case Else
            GoTo NoEntry
      End Select
          'if there is an appointment with same starting time and subject
            If CheckAppointmentExists(dCell.Offset(0, -2) + TimeValue(STime), Subj) = 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 " & Subj & " item from " & STime & " until " & ETime & " 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(STime)
                           .End = dCell.Offset(0, -2) + TimeValue(ETime)
                           .Subject = Subj
                       .Save
                   End With
               End If
NoEntry:
    Next dCell
End Sub
```


----------



## Phil810 (Sep 27, 2018)

*Re: VBA - Connect excel with Outlook problem?!*

Yea you were right...Guess I was too tired at that point..And yes the dublicate was because I had customized the calendar to another one than the default one, somehow that ****ed it up. But now its all good - it works perfectly, though its a bit slow, but I guess thats just due to the capabilities of VBA, so thanks a lot for the help, Kamolga


----------



## Kamolga (Sep 27, 2018)

*Re: VBA - Connect excel with Outlook problem?!*

Glad to help. I resigned to work in default calendar myself, I had too much trubbles the other way.
To increase the speed, 

```
Sub blablabla()
Application.ScreenUpdating = False
Application.Calculation = xlManual

[COLOR=#008000]'Write the macro[/COLOR]

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub
```
 sometimes work


----------



## Phil811 (Mar 27, 2019)

*Re: VBA - Connect excel with Outlook problem?!*

Long time no see!

I have another question i hope you can help me with 

Im trying to look at multiple ranges and check each cells with an if sentence in order to replace letters with words e.g. If the cells reads "AR" replace it with "Night"..This works perfectly if I say Range("D10:D40") but not if i say Union(Range("D10:D40"), Range("L10:L40"), Range("T10:T40")...Then it says 'Type mismatch' error 2042...

Code:

 For Each cell In Range("D10:D40")
    If cell.Value = "NR" Then
        cell.Value = "Nat"
    End If
 Next cell

Code :
For Each cell In Union(Range("D10:D40"), Range("L10:L40"), Range("T10:T40"), Range("D49:D79"), Range("L49:L79"), Range("T49:T79"), Range("D88:D117"), Range("L88:L117"), Range("T88:T117"), Range("D127:D153"), Range("L127:L157"), Range("T127:T157"))
    If cell.Value = "AR" Then
        cell.Value = "Aften"
    End If
 Next cell


----------



## Kamolga (Mar 28, 2019)

*Re: VBA - Connect excel with Outlook problem?!*

Hi,

You don't need "union" actually, simply separate references with a coma

```
[COLOR=#222222][FONT=Verdana]Dim rCell As Range[/FONT][/COLOR]
[COLOR=#222222][FONT=Verdana]Dim SearchArea As Range: Set SearchArea =[/FONT][/COLOR]ActiveSheet[B].[COLOR=#0000ff]Range("D10:D40,L10:L40,T10:T40,D49:D79,L49:L79,T49:T79,D88:D117,L88:L117,T88:T117,D127:D153,L127:L157,T127:T157")[/COLOR][/B]

[COLOR=#222222][FONT=Verdana]    For Each rCell In SearchArea[/FONT][/COLOR]
[COLOR=#222222][FONT=Verdana]        If rCell.Value = "AR" Then[/FONT][/COLOR]
[COLOR=#222222][FONT=Verdana]           rCell.Value = "Nat"[/FONT][/COLOR]
[COLOR=#222222][FONT=Verdana]        End If[/FONT][/COLOR]
[COLOR=#222222][FONT=Verdana]    Next rCell[/FONT][/COLOR]
```


----------



## Phil810 (Mar 28, 2019)

*Re: VBA - Connect excel with Outlook problem?!*

Okay thanks.

But it did actually work with union it was just a reference error in a single cell.


----------



## Phil811 (Apr 4, 2019)

*Re: VBA - Connect excel with Outlook problem?!*

Hi again Kamolga,

I have another question - im trying to all the cells where "Dag" "Aften" "Nat" and so on, occurs - but everytime i do so it just gives me #Value in the assigned cell.

Sub Tældage()
Dim MyRange As Range
Set MyRange = Union(Range("D10:D40"), Range("L10:L39"), Range("T10:T40"), Range("D49:D79"), Range("L49:L78"), Range("T49:T79"), Range("D88:D117"), Range("L88:L118"), Range("T88:T118"), Range("D127:D155"), Range("L127:L157"), Range("T127:T156"))
Range("AS1") = Application.CountIf(MyRange, "Dag")


End Sub


----------



## Kamolga (Apr 5, 2019)

*Re: VBA - Connect excel with Outlook problem?!*

COUNTIF doesn't work with discontiguous ranges.

```
Sub T?ldage()
Dim rCell As Range
Dim SearchArea As Range: Set SearchArea = ActiveSheet.Range("D10:D40,L10:L40,T10:T40,D49:D79,L49:L79,T49:T79,D88:D117,L88:L117,T88:T117,D127:D153,L127:L157,T127:T157")
Dim TotDag As Range: Set TotDag = ActiveSheet.Range("AS1")
TotDag.Value = 0
    For Each rCell In SearchArea
        If rCell.Value = "Dag" Then
           TotDag.Value = TotDag.Value + 1
        End If
    Next rCell
End Sub
```

​


----------



## Phil810 (Sep 18, 2018)

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:


```
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 timerTimerOverArbejde01-majtirsdagdag8,2502-majonsdagaften8,9803-majtorsdagaften816,9804-majfredagaften8,9805-majlørdagaften8,9806-majsøndagaften8,9807-majmandagaften8,9808-majtirsdagaften8,9809-majonsdagovertid aft udb17,9610-majtorsdagaften8,9811-majfredag12-majlørdag13-majsøndag14-majmandag15-majtirsdag16-majonsdag4,54,517-majtorsdagdag19,2518-majfredagdag8,2519-majlørdag20-majsøndag21-majmandag22-majtirsdagdag1,259,523-majonsdagdag1,751024-majtorsdag25-majfredagaften8,9826-majlørdagaften8,2517,2327-majsøndagaften8,2517,2328-majmandag29-majtirsdag30-majonsdag31-majtorsdag

<tbody>

</tbody>

I hope someone can help me


----------



## Phil811 (Apr 6, 2019)

*Re: VBA - Connect excel with Outlook problem?!*

Seems a bit weird that it has to be this much hassle to count in ranges..but it works like a charm - thanks!

How do I then update this cell when ever a new value is added to the range? So that I dont have to update it constantly or forget to update it?


----------



## Kamolga (Apr 7, 2019)

*Re: VBA - Connect excel with Outlook problem?!*

If you want the total of Dag and Nacht for example, you can use


```
[LEFT][COLOR=#333333][FONT=monospace] If (rCell.Value = "Dag" or [COLOR=#333333][FONT=monospace]rCell.Value = "Nacht") then[/FONT][/COLOR][/FONT][/COLOR][/LEFT]
```
.
and keep on adding or rcell.value="xxx".
If you want the total of all values without knowing what they would be, you need to count whenever no empty


```
[LEFT][COLOR=#333333][FONT=monospace]if rCell <> "" then[/FONT][/COLOR][/LEFT]
```


----------



## Phil811 (Apr 10, 2019)

*Re: VBA - Connect excel with Outlook problem?!*

Okay good to know.

But I still have the problem of how I then update this cell when ever a new value is added to the range? So that I dont have to update it constantly or forget to update it?

And also in reference to the original Excel to outlook matter - the Cases you showed me are case sensitive so if you for instance  type in Dag instead of dag into excel it wont enter it in outlook - is there a way to make the cases non case sensitive - i tried just adding an 'or' so Case "Dag" or "dag"...But it didnt work.

Hope you can help


----------



## Kamolga (Apr 10, 2019)

*Re: VBA - Connect excel with Outlook problem?!*

The function ucase transform the text in UPPERCASE, so


```
[LEFT][COLOR=#008000][FONT=monospace]Select Case ucase(dCell.Value)
       Case "DAG"
[/FONT][/COLOR][/LEFT]
```

will concider Dag, dag, dAG, etc. being true


----------



## Kamolga (Apr 10, 2019)

*Re: VBA - Connect excel with Outlook problem?!*



Phil811 said:


> how I then update this cell when ever a new value is added to the range? So that I dont have to update it constantly or forget to update it?


My way is to work with tables: when you add a row to a table, it extends automatically, so the range is dynamic.
Another way is to name (define name in formula tab) and use those names in VBA, so you update a name once and it works wit all your macro. The issue is that if you don't use your file for 2 months, it is very difficult to get back to it...so using tables (with names, you can name columns) is a bit more time consuming in the beginning but worth the effort


----------

