Copy Appointments

[Nasstaucher]

Hello,

I want to copy all appointments from calender to another calender. Bothe are not default, but the names are everytime the same. So they can stand in the code. I have found this idea in the internet, but I don't have the knowledege to edit the code. I use outlook 2010. If I restart the macro, its not allowed to insert doubles.

Can somebody help me? Thanks.

Sub Copy()
Dim objKalender As MAPIFolder
Dim objItem As Object

Set objKalender = Application.Session.GetDefaultFolder(9)
Set objKalender = objKalender.Folders("Test")

For Each objItem In objKalender.Items
If TypeName(objItem) = "AppointmentItem" Then
With objItem
If .Start > CDate("01.05.2004") And .Start < CDate("20.05.2004") Then
.Start = DateAdd("h", 1, .Start)
.Save
End If
End With
End If
Next objItem
End Sub