Onderstaande macro gebruik ik om een outlook agenda te vullen alleen loop ik tegen het volgende aan.
De gefilterde/verborgen regels worden nu niet overgeslagen. Hoe kan ik dat oplossen
mvg
Kasper
De gefilterde/verborgen regels worden nu niet overgeslagen. Hoe kan ik dat oplossen
Code:
Sub Export1()
Dim olApp As Outlook.Application
Dim olFolder As Outlook.MAPIFolder
Dim I As Long
Dim xRg As Range
Dim xOutItem As Object
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
If Err.Number > 0 Then Set olApp = CreateObject("Outlook.Application")
On Error GoTo 0
Set olFolder = olApp.GetNamespace("MAPI").PickFolder
If olFolder Is Nothing Then
GoTo ErrorHandler:
End If
Set xRg = ActiveSheet.Range("A2:M" & ActiveSheet.Cells.Find("*", LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row)
[COLOR="#B22222"] For I = 1 To xRg.Rows.Count[/COLOR]
Set xOutItem = olFolder.Items.Add
Debug.Print xRg.Cells(I, 1).Value
xOutItem.Subject = xRg.Cells(I, 1).Value
xOutItem.Start = xRg.Cells(I, 2).Value + xRg.Cells(I, 3).Value
xOutItem.End = xRg.Cells(I, 4).Value + xRg.Cells(I, 5).Value
If xRg.Cells(I, 6).Value = "Ja" Then
xOutItem.AllDayEvent = True
Else
xOutItem.AllDayEvent = False
End If
If xRg.Cells(I, 7).Value = "Geen" Then
xOutItem.ReminderSet = False
ElseIf xRg.Cells(I, 7).Value = "0 minuten" Then
xOutItem.ReminderSet = True
xOutItem.ReminderMinutesBeforeStart = 0
ElseIf xRg.Cells(I, 7).Value = "5 minuten" Then
xOutItem.ReminderSet = True
xOutItem.ReminderMinutesBeforeStart = 5
ElseIf xRg.Cells(I, 7).Value = "10 minuten" Then
xOutItem.ReminderSet = True
xOutItem.ReminderMinutesBeforeStart = 10
ElseIf xRg.Cells(I, 7).Value = "15 minuten" Then
xOutItem.ReminderSet = True
xOutItem.ReminderMinutesBeforeStart = 15
ElseIf xRg.Cells(I, 7).Value = "30 minuten" Then
xOutItem.ReminderSet = True
xOutItem.ReminderMinutesBeforeStart = 30
ElseIf xRg.Cells(I, 7).Value = "1 uur" Then
xOutItem.ReminderSet = True
xOutItem.ReminderMinutesBeforeStart = 60
ElseIf xRg.Cells(I, 7).Value = "2 uur" Then
xOutItem.ReminderSet = True
xOutItem.ReminderMinutesBeforeStart = 120
ElseIf xRg.Cells(I, 7).Value = "3 uur" Then
xOutItem.ReminderSet = True
xOutItem.ReminderMinutesBeforeStart = 180
ElseIf xRg.Cells(I, 7).Value = "4 uur" Then
xOutItem.ReminderSet = True
xOutItem.ReminderMinutesBeforeStart = 240
ElseIf xRg.Cells(I, 7).Value = "5 uur" Then
xOutItem.ReminderSet = True
xOutItem.ReminderMinutesBeforeStart = 300
ElseIf xRg.Cells(I, 7).Value = "6 uur" Then
xOutItem.ReminderSet = True
xOutItem.ReminderMinutesBeforeStart = 360
ElseIf xRg.Cells(I, 7).Value = "7 uur" Then
xOutItem.ReminderSet = True
xOutItem.ReminderMinutesBeforeStart = 420
ElseIf xRg.Cells(I, 7).Value = "8 uur" Then
xOutItem.ReminderSet = True
xOutItem.ReminderMinutesBeforeStart = 480
ElseIf xRg.Cells(I, 7).Value = "9 uur" Then
xOutItem.ReminderSet = True
xOutItem.ReminderMinutesBeforeStart = 540
ElseIf xRg.Cells(I, 7).Value = "10 uur" Then
xOutItem.ReminderSet = True
xOutItem.ReminderMinutesBeforeStart = 600
ElseIf xRg.Cells(I, 7).Value = "11 uur" Then
xOutItem.ReminderSet = True
xOutItem.ReminderMinutesBeforeStart = 660
ElseIf xRg.Cells(I, 7).Value = "0" & Chr(130) & "5 dagen" Then
xOutItem.ReminderSet = True
xOutItem.ReminderMinutesBeforeStart = 720
ElseIf xRg.Cells(I, 7).Value = "18 uur" Then
xOutItem.ReminderSet = True
xOutItem.ReminderMinutesBeforeStart = 1080
ElseIf xRg.Cells(I, 7).Value = "1 dag" Then
xOutItem.ReminderSet = True
xOutItem.ReminderMinutesBeforeStart = 1440
ElseIf xRg.Cells(I, 7).Value = "2 dagen" Then
xOutItem.ReminderSet = True
xOutItem.ReminderMinutesBeforeStart = 2880
ElseIf xRg.Cells(I, 7).Value = "3 dagen" Then
xOutItem.ReminderSet = True
xOutItem.ReminderMinutesBeforeStart = 5760
ElseIf xRg.Cells(I, 7).Value = "4 dagen" Then
xOutItem.ReminderSet = True
xOutItem.ReminderMinutesBeforeStart = 11520
ElseIf xRg.Cells(I, 7).Value = "1 week" Then
xOutItem.ReminderSet = True
xOutItem.ReminderMinutesBeforeStart = 10080
ElseIf xRg.Cells(I, 7).Value = "2 weken" Then
xOutItem.ReminderSet = True
xOutItem.ReminderMinutesBeforeStart = 20160
End If
xOutItem.Body = xRg.Cells(I, 8).Value
xOutItem.Categories = xRg.Cells(I, 9).Value
xOutItem.Location = xRg.Cells(I, 10).Value
If xRg.Cells(I, 11).Value = "Lage urgentie" Then
xOutItem.Importance = olImportanceLow '0 - Lage urgentie
ElseIf xRg.Cells(I, 11).Value = "" Then
xOutItem.Importance = olImportanceNormal '1 - Normale urgentie
ElseIf xRg.Cells(I, 11).Value = "Hoge urgentie" Then
xOutItem.Importance = olImportanceHigh '2 - Hoge urgentie
End If
If xRg.Cells(I, 12).Value = "" Then
xOutItem.Sensitivity = olNormal '0 - Normal sensitivity
ElseIf xRg.Cells(I, 12).Value = "Personal" Then
xOutItem.Sensitivity = olPersonal '1 - Personal
ElseIf xRg.Cells(I, 12).Value = "Private" Then
xOutItem.Sensitivity = olPrivate '2 - Private
ElseIf xRg.Cells(I, 12).Value = "Confidential" Then
xOutItem.Sensitivity = olConfidential '3 - Confidential
End If
If xRg.Cells(I, 13).Value = "Vrij" Then
xOutItem.BusyStatus = olFree '0 - Vrij
ElseIf xRg.Cells(I, 13).Value = "Voorlopig bezet" Then
xOutItem.BusyStatus = olTentative '1 - Voorlopig bezet
ElseIf xRg.Cells(I, 13).Value = "Bezet" Then
xOutItem.BusyStatus = olBusy '2 - Bezet
ElseIf xRg.Cells(I, 13).Value = "Niet aanwezig" Then
xOutItem.BusyStatus = olOutOfOffice '3 - Niet aanwezig
ElseIf xRg.Cells(I, 13).Value = "Elders werkend" Then
xOutItem.BusyStatus = olWorkingElsewhere '4 - Elders werkend
End If
xOutItem.Save
Set xOutItem = Nothing
Next
ErrorHandler:
Set olApp = Nothing
Set olFolder = Nothing
Set xRg = Nothing
Set xOutItem = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
End Sub
mvg
Kasper