ok yazanlarda işlem yapmasın

[kneehot]

Arkadaşlar merhaba, elimde bir makro var fakat bir eksiği var. 24. kolona takvime ekledikten sonra ok yazıyor fakat tekrar çalıştırınca daha önce takvime eklediği bilgileri 24. kolonda ok yazmasına rağmen tekrar ekliyor. 24 te ok yazanlar ile ilgili işlem yapmasın istiyorum. Makroyu aşağıya ekliyorum, şimdiden tüm yardımlara çok teşekkürler.

Sub OutLook_Takvime_Olay_Ata()

Dim oOutLook As Object
Dim oRandevu As Object

On Error Resume Next
Set oOutLook = GetObject(, "Outlook.Application")
If Err.Number = 429 Then
Set oOutLook = CreateObject("Outlook.application")
End If
On Error GoTo 0

Set oRandevu = oOutLook.CreateItem(olAppointmentItem)

On Error Resume Next

For i = 4 To Cells(501, 3).End(xlUp).Row
With oRandevu
.Start = Cells(i, 19) + Cells(i, 20)
.End = Cells(i, 19) + Cells(i, 20)
.Subject = Cells(i, 21)
.Location = Cells(i, 22)
.Body = Cells(i, 23)
If Len(Cells(i, 25)) > 0 Then
If IsNumeric(Cells(i, 25)) Then
.ReminderMinutesBeforeStart = Cells(i, 25)
.ReminderSet = True
End If
End If

If Err <> 0 Then
Cells(i, 24) = "HATA"
Else
.Save
Cells(i, 24) = "OK"
Err = 0
End If
End With
Next i

Set oOutLook = Nothing
Set oRandevu = Nothing
End Sub

 

[Levent Menteşoğlu]

Aşağıdaki kırmızı renkli ilaveleri yaparak deneyin.

Sub OutLook_Takvime_Olay_Ata()

Dim oOutLook As Object
Dim oRandevu As Object

On Error Resume Next
Set oOutLook = GetObject(, "Outlook.Application")
If Err.Number = 429 Then
Set oOutLook = CreateObject("Outlook.application")
End If
On Error GoTo 0

Set oRandevu = oOutLook.CreateItem(olAppointmentItem)

On Error Resume Next

For i = 4 To Cells(501, 3).End(xlUp).Row

if Cells(i, 24)="OK" then goto 10

With oRandevu
.Start = Cells(i, 19) + Cells(i, 20)
.End = Cells(i, 19) + Cells(i, 20)
.Subject = Cells(i, 21)
.Location = Cells(i, 22)
.Body = Cells(i, 23)
If Len(Cells(i, 25)) > 0 Then
If IsNumeric(Cells(i, 25)) Then
.ReminderMinutesBeforeStart = Cells(i, 25)
.ReminderSet = True
End If
End If

If Err <> 0 Then
Cells(i, 24) = "HATA"
Else
.Save
Cells(i, 24) = "OK"
Err = 0
End If
End With
10 Next i

Set oOutLook = Nothing
Set oRandevu = Nothing
End Sub

 

[kneehot]

Aşağıdaki kırmızı renkli ilaveleri yaparak deneyin.

Sub OutLook_Takvime_Olay_Ata()

Dim oOutLook As Object
Dim oRandevu As Object

On Error Resume Next
Set oOutLook = GetObject(, "Outlook.Application")
If Err.Number = 429 Then
Set oOutLook = CreateObject("Outlook.application")
End If
On Error GoTo 0

Set oRandevu = oOutLook.CreateItem(olAppointmentItem)

On Error Resume Next

For i = 4 To Cells(501, 3).End(xlUp).Row

if Cells(i, 24)="OK" then goto 10

With oRandevu
.Start = Cells(i, 19) + Cells(i, 20)
.End = Cells(i, 19) + Cells(i, 20)
.Subject = Cells(i, 21)
.Location = Cells(i, 22)
.Body = Cells(i, 23)
If Len(Cells(i, 25)) > 0 Then
If IsNumeric(Cells(i, 25)) Then
.ReminderMinutesBeforeStart = Cells(i, 25)
.ReminderSet = True
End If
End If

If Err <> 0 Then
Cells(i, 24) = "HATA"
Else
.Save
Cells(i, 24) = "OK"
Err = 0
End If
End With
10 Next i

Set oOutLook = Nothing
Set oRandevu = Nothing
End Sub

Levent bey merhaba yardımınız için çok teşekkürler, kodu ekledim çalışıyor fakat tüm kodun çalışmasında bir sıkıntı var bazı satırları eklemiyor. Tüm makroyu kontrol etme şansınız varmıdır rica etsem.