Excel verilerinden randevu nasıl oluşturulur?

Varsayalım, aşağıdaki ekran görüntüsünün gösterildiği gibi bir Excel çalışma sayfasında bir randevu verisi tablosu var, şimdi bu verileri Outlook takvimine aktarmak istiyorsunuz. Bu iş ile nasıl başa çıkabildin?

VBA kodu ile Excel verilerinden randevu oluşturma

VBA kodu ile Excel verilerinden randevu oluşturma

Excel verilerinden randevu oluşturmak için, aşağıdaki VBA kodunu uygulayabilirsiniz, lütfen şu şekilde yapın:

1. Outlook'u başlatın ve basılı tutun ALT + F11 tuşlarını açmak için Uygulamalar için Microsoft Visual Basic pencere.

2. tıklayın Ekle > modülve aşağıdaki kodu yapıştırın: modül Pencere.

VBA kodu: Randevu için excel verilerini içe aktarın:

Public Sub CreateOutlookApptz()
    Dim xAppointmentItem As Outlook.AppointmentItem
    Dim xNameSpace As Outlook.NameSpace
    Dim xCalendarFld As Outlook.MAPIFolder, xSubFolder As Outlook.MAPIFolder
    Dim xCalendarStr As String
    Dim I As Long
    Dim xFileDialog As FileDialog
    Dim xFilePath As String
    Dim xExcelApp As Excel.Application
    Dim xWb As Workbook
    Dim xWs As Worksheet
    On Error GoTo Err_Execute
    Set xExcelApp = New Excel.Application
    Set xFileDialog = xExcelApp.FileDialog(msoFileDialogFilePicker)
    With xFileDialog
        .Title = "Select a file"
        .Filters.Add "Microsoft Excel", "*.xlsx"
    End With
    If xFileDialog.Show = 0 Then Exit Sub
    xFilePath = xFileDialog.SelectedItems(1)
    Set xWb = xExcelApp.Workbooks.Open(xFilePath)
    Set xNameSpace = Outlook.Application.Session
    Set xCalendarFld = xNameSpace.GetDefaultFolder(olFolderCalendar)
    I = 2
    Set xWs = xWb.Worksheets.Item(1)
    xCalendarStr = xWb.Name
    If FolderExist(xCalendarFld, xCalendarStr) = False Then
        Set xSubFolder = xCalendarFld.Folders.Add(xCalendarStr, olFolderCalendar)
    Else
        Set xSubFolder = xCalendarFld.Folders(xCalendarStr)
    End If
    Do Until Trim(xWs.Cells(I, 1).Value) = ""
        Set xAppointmentItem = xSubFolder.Items.Add(olAppointmentItem)
        With xAppointmentItem
            .Start = xWs.Cells(I, 5) + xWs.Cells(I, 6)
            .End = xWs.Cells(I, 7) + xWs.Cells(I, 8)
            .Subject = xWs.Cells(I, 1)
            .Location = xWs.Cells(I, 2)
            .Body = xWs.Cells(I, 3)
            .BusyStatus = olBusy
            .ReminderMinutesBeforeStart = xWs.Cells(I, 9)
            .ReminderSet = True
            .Categories = xWs.Cells(I, 4)
            .Save
        End With
        I = I + 1
    Loop
    Set xAppointmentItem = Nothing
    Set olApp = Nothing
    xExcelApp.Quit
    Set xExcelApp = Nothing
    MsgBox "Import successfully!", vbInformation, "Kutools for Outlook"
    Exit Sub
Err_Execute:
    MsgBox "An error occurred - Exporting items to Calendar.", vbInformation, "Kutools for Outlook"
End Sub
Function FolderExist(CalFolder As Folder, FolderName As String) As Boolean
    Dim I As Integer
    Dim xSubFolder As Folder
    For I = 1 To CalFolder.Folders.Count
        Set xSubFolder = CalFolder.Folders.Item(I)
        If xSubFolder.Name = FolderName Then
            FolderExist = True
            Exit Function
        End If
    Next I
End Function

3. Hala içinde Uygulamalar için Microsoft Visual Basic Pencere, tıklayın Araçlar > Referanslar gitmek için Kaynaklar-Project1 iletişim kutusu ve kontrol Microsoft Excel Nesne Kitaplığı seçeneği Mevcut Kaynaklar liste kutusu, ekran görüntüsüne bakın:

4. Sonra tıklayın OK düğmesine şimdi basın F5 Bu kodu çalıştırmak için Bir dosya seçin penceresi görüntülenir, lütfen Outlook'a aktarmak istediğiniz excel dosyasını seçin, ekran görüntüsüne bakın:

5. Ve sonra tıklayın OK, aşağıdaki gibi bir istem kutusu açılır:

6. Sonra tıklayın OK, Excel verileri gösterilen ekran görüntüsüne göre takvime içe aktarıldı:

Kutools for Outlook

Outlook için 100'ten Fazla Gelişmiş İşlevler 2010, 2013, 2016, 2019 ve 365

Diğer Özellikler | Bedava indir | Yüzlerce işlev için yalnızca $ 39.00