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
You are guest ( Sign Up? )
or post as a guest, but your post won't be published automatically.
Be the first to comment.