Excel 루프에서 만들 때 Outlook 약속을 덮어 쓰는 중

Question

Excel 시트의 정보를 반복하여 Outlook에 약속을 만듭니다. 그것을 내 기본 폴더로 보냈을 때 작동했습니다.

데이터를 특정 폴더 (동료가 공유)로 업로드하도록 변경했습니다.

그때 이후로 나는 F8에서 내 코드를 통해 반복되는 행에 대한 약속을 저장합니다. 그러나 다음 행으로 이동하면 새 약속이 저장되는 대신 구형으로 바뀝니다.

Sub ExportToOutlook   

Dim OL as Outlook.Application, Appoint as Outlook.AppointmentItem, ES as Worksheet, _ 
     r as Long, i as Long, WB as ThisWorkook, oFolder as Object, o NameSpace as Namespace 

    Set WB = ThisWorkbook 
    Set ES = WB.Sheets("Export Sheet") 
    r = ES.Cells(Rows.count,1).End(xlUp).Row 
    Set OL = New Outlook.Application 
    Set oNameSpace = OL.GetNamespace("MAPI") 
    Set oFolder = oNameSpace.GetFolderFromID("Insert the ID").Items.Add(olAppointmentItem) 

For i = 2 to r 
    With oFolder 
     .Subject = ES.Cells(i,1).Value 
     .Start = ES.Cells(i,2).Value 
     .End = ES.Cells(i,3).Value 
     .Location = ES.Cells(i,4).Value 
     .AllDayEvent = ES.Cells(i,5).Value 
     .Categories = ES.Cells(i,6).Value & " Category" 
     .Save 
    End With 
Next i 

Set OL = Nothing 

End Sub 

Answer 1

각 행 반복마다 동일한 폴더를 다시 업데이트하는 것처럼 보입니다. 다음을 시도해보십시오.

Sub ExportToOutlook   

Dim OL as Outlook.Application, Appoint as Outlook.AppointmentItem, ES as Worksheet, _ 
     r as Long, i as Long, WB as ThisWorkook, oFolder as Object, o NameSpace as Namespace 

    Set WB = ThisWorkbook 
    Set ES = WB.Sheets("Export Sheet") 
    r = ES.Cells(Rows.count,1).End(xlUp).Row 
    Set OL = New Outlook.Application 
    Set oNameSpace = OL.GetNamespace("MAPI") 
    Set oFolder = oNameSpace.GetFolderFromID("Insert the ID") 

For i = 2 to r 
    Dim appt as MailItem 
    Set appt = oFolder.Items.Add(olAppointmentItem) 
    With appt 
     .Subject = ES.Cells(i,1).Value 
     .Start = ES.Cells(i,2).Value 
     .End = ES.Cells(i,3).Value 
     .Location = ES.Cells(i,4).Value 
     .AllDayEvent = ES.Cells(i,5).Value 
     .Categories = ES.Cells(i,6).Value & " Category" 
     .Save 
    End With 
Next i 

Set OL = Nothing 

End Sub 

Answer 2

Outlook AppointmentItem이 저를위한 해결책이었습니다!

Sub ExportToOutlook2() 

    Dim OL As Outlook.Application, ES As Worksheet, _ 
    r As Long, i As Long, WB As ThisWorkbook, oFolder As Object, oNameSpace As Namespace 

    Set WB = ThisWorkbook 
    Set ES = WB.Sheets("Export Sheet") 
    r = ES.Cells(Rows.count, 1).End(xlUp).Row 
    Set OL = New Outlook.Application 
    Set oNameSpace = OL.GetNamespace("MAPI") 
    Set oFolder = oNameSpace.GetFolderFromID("00000000579E67EAD9C2C94591E62A3CF21135F801001241364BFDA9AF49A3D3384A976997C50036FCD700060000") 

    For i = 2 To r 
     Dim appt As Outlook.AppointmentItem 
     Set appt = oFolder.Items.Add(olAppointmentItem) 
     With appt 
      .Subject = ES.Cells(i, 1).Value 
      .Start = ES.Cells(i, 2).Value 
      .End = ES.Cells(i, 3).Value 
      .Location = ES.Cells(i, 4).Value 
      .AllDayEvent = ES.Cells(i, 5).Value 
      .Categories = ES.Cells(i, 6).Value 
      .Save 
     End With 
    Next i 

    Set OL = Nothing 

    End Sub