Thread: Transfer data from Excel to Outlook Calendar

Hi Hatye

See this thread. It sounds like what you're doing http://www.excelforum.com/excel-prog...-calender.html

John

Hi Hatye

Couple things. This line of code evaluates to 100

LR = Ark2.Range("A" & Rows.Count).End(xlUp).Row

when you have only 27 rows in column A of Ark2 so you need to delete all the extraneous data below your last row.

Secondly

Public strName As String

isn't defined anywhere in the code you posted so, the code isn't finding any records. What is strName and where does the value come from?

Can't test the code until this is defined.

Alternately, simply explain what it is you wish to do. Perhaps I can help.

John

Hi Hatye
Yes, I

understand what I want to do

I'll work on this for you.

John

Hi Hatye

You'll notice that I made very few changes to your original code; your offsets were off.

Option Explicit
Sub Transfer_Outlook()
    Dim objApp As Outlook.Application
    Dim objNS As Outlook.Namespace
    Dim objFolder As Outlook.MAPIFolder
    Dim objRecip As Outlook.Recipient
    Dim objAppt As Outlook.AppointmentItem
    Dim UseSubject As String
    Dim UseLocation As String
    Dim UseBody As String
    Dim UseDate As Date
    Dim UseCategory As String
    Dim LR As Long
    Dim nCell As Range
    Dim Rng As Range
    Dim StartTime As String
    Dim EndTime As String
    On Error Resume Next
    Set objApp = CreateObject("Outlook.Application")
    On Error GoTo 0
    LR = Ark2.Range("A" & Rows.Count).End(xlUp).Row
    Set Rng = Ark2.Range("A2:A" & LR)
    For Each nCell In Rng
        If Not nCell = "" Then
            On Error Resume Next
            Set objNS = objApp.GetNamespace("MAPI")
            Set objFolder = objNS.GetDefaultFolder(olFolderCalendar)
            UseSubject = nCell.Offset(0, 0).Value '& " - " & nCell.Offset(0, -4).Value
            UseDate = nCell.Offset(0, 1).Value
            UseLocation = nCell.Offset(0, 7).Value
            UseBody = nCell.Offset(0, 6).Value
            UseCategory = nCell.Offset(0, 8).Value
            StartTime = nCell.Offset(0, 2).Value
            EndTime = nCell.Offset(0, 4).Value
            If Not objFolder Is Nothing Then
                Set objAppt = objFolder.Items.Add
                If Not objAppt Is Nothing Then
                    With objAppt
                        .Start = UseDate + StartTime
                        .End = UseDate + EndTime
                        .Subject = UseSubject
                        .Location = UseLocation
                        .Body = UseBody
                        .Category = UseCategory
                        .Save
                    End With
                End If
            Else
                'MsgBox "Could not find " & Chr(34) & nCell & Chr(34), , _
                        "User not found"
            End If
            On Error GoTo 0
        End If
    Next nCell
    Set objApp = Nothing
    Set objNS = Nothing
    Set objFolder = Nothing
    Set objRecip = Nothing
    Set objAppt = Nothing
End Sub

Let me know of issues.

John

Hi Hatye

I assume you have "Skole" set up as a Category in Outlook. Assuming you do, you need to change this line of code from

.Category = UseCategory

to

.Categories = UseCategory

Let me know of issues.

John

Hi Hatye

Have you tried Categories ?

.Categories = UseCategory

Yes, the above code works for me.

John

Sub tst()
  sq = Sheets(1).Cells(1).CurrentRegion

  With CreateObject("outlook.application")
    For j = 2 To UBound(sq)
      With .createitem(1)
        .Subject=sq(j,1)
        .Start=sq(j,2) + sq(j,3)
        .End=sq(j,4) + sq(j,5)
        .Body=sq(j,7)
        .Location=sq(j,8)
        .Categories=sq(j,9)
        .Save
      End With
    Next
  End With
End Sub

Glad it works for you. If your issue is resolved, please mark your thread solved.

John