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

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)

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.
 
Last edited:
Upvote 0

Excel Facts

How to fill five years of quarters?
Type 1Q-2023 in a cell. Grab the fill handle and drag down or right. After 4Q-2023, Excel will jump to 1Q-2024. Dash can be any character.
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?
 
Upvote 0
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..
Click to expand...

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")​
Code: 
[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:

Code: 
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
 
Last edited:
Upvote 0
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 :)
 
Upvote 0
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,
Code: 
Sub blablabla()
Application.ScreenUpdating = False
Application.Calculation = xlManual

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

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub
sometimes work
 
Last edited:
Upvote 0
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
 
Upvote 0
Re: VBA - Connect excel with Outlook problem?!

Hi,

You don't need "union" actually, simply separate references with a coma
Code: 
[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]
 
Last edited:
Upvote 0
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.
 
Upvote 0
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
 
Upvote 0
Re: VBA - Connect excel with Outlook problem?!

COUNTIF doesn't work with discontiguous ranges.
Code: 
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

​
 
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
977
BSALV
BSALV

Forum statistics

Threads
1,215,195
Messages
6,123,572
Members
449,108
Latest member
rache47

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