Question

我已经搜索了很多主题，似乎没有任何解决方案适合我。

我的Excel宏文件有时可以正常工作，但有时只能在步进模式下工作。

这是主子内部的一个子，它按类别（键）从Outlook日历中将值（消息）传递给电子表格。（对于此代码我改编自Script to total hours by calendar category in Outlook）。该值将进入与该类别相同的行以及该列中的周值。我已经尝试了DoEvents，我认为它有效，但当我尝试在另一台计算机上运行它时，它又失败了。

有什么想法吗？

Option Explicit
Public keyArray
Sub totalCategories()


Dim app As New Outlook.Application
Dim namespace As Outlook.namespace
Dim calendar As Outlook.Folder
Dim appt As Outlook.AppointmentItem
Dim apptList As Outlook.Items
Dim apptListFiltered As Outlook.Items
Dim startDate As String
Dim endDate As String
Dim category As String
Dim duration As Integer
Dim outMsg As String
Dim firstDayOfTheYear As Date

'Going to be used to get start and end date
firstDayOfTheYear = Date
firstDayOfTheYear = "01/01/" & Right(firstDayOfTheYear, 4)

' Access appointment list
Set namespace = app.GetNamespace("MAPI")
Set calendar = namespace.GetDefaultFolder(olFolderCalendar)
Set apptList = calendar.Items

' Include recurring appointments and sort the list
apptList.IncludeRecurrences = True
apptList.Sort "[Start]"

' Get selected date
startDate = firstDayOfTheYear + 7 * (CInt(SelectWeek.week) - 1)
endDate = firstDayOfTheYear + 7 * (CInt(SelectWeek.week) - 1) + 6
startDate = Format(startDate, "dd/MM/yyyy") & " 00:01"
endDate = Format(endDate, "dd/MM/yyyy") & " 11:59 PM"

' Filter the appointment list
Dim strFilter As String
strFilter = "[Start] >= '" & startDate & "'" & " AND [End] <= '" & endDate & "'"
Set apptListFiltered = apptList.Restrict(strFilter)

' Loop through the appointments and total for each category
Dim catHours
Set catHours = CreateObject("Scripting.Dictionary")
For Each appt In apptListFiltered
    category = appt.Categories
    duration = appt.duration
    If catHours.Exists(category) Then
        catHours(category) = catHours(category) + duration
    Else
        catHours.Add category, duration
    End If
Next

' Loop through the categories
Dim key
keyArray = catHours.Keys
DoEvents 'prevents a bug from happening --> in some cases the total hours weren't divided by categories
For Each key In keyArray
    outMsg = catHours(key) / 60
    'Print in Realizado sheet --> activities must be in range (name manager) as "atividades"
    writeReport SelectWeek.week, outMsg, key
Next

' Clean up objects
Set app = Nothing
Set namespace = Nothing
Set calendar = Nothing
Set appt = Nothing
Set apptList = Nothing
Set apptListFiltered = Nothing

End Sub

Sub writeReport(week, message As String, key)

    Dim ws As Worksheet
    Dim i As Integer
    Dim Activities, nActivities As Integer

    Set ws = Sheets("5")
    Activities = Range("activities")
    nActivities = UBound(Activities)
    DoEvents
    For i = 1 To nActivities
        DoEvents 
        If key = Cells(i + 8, 2).Value Then
            ws.Cells(i + 8, week + 3).Value = CDbl(message)
            Exit For
        End If
    Next i

End Sub

Answer 1

您需要明确处理错误，以便准确了解正在发生的事情。请相信我，这将为您节省大量时间来排除自己的代码，尤其是在VBA中。

通常的做法是＆＃34;尝试，捕捉，最后＆＃34;。

Dim position as string

Sub foo()
  position = "sub function short description"
  On Error GoTo catch
  Err.Clear

  'do stuff

finally:
  On Error Resume Next
  'do cleanup stuff

  Exit Sub

catch:
  Debug.Print Right(ThisWorkbook.FullName, Len(ThisWorkbook.FullName) - 3) & ", _
  Position: " & errorPosition & " , Error Code: [ " & Hex(Err.number) & "], _
  Description: " & Err.Description & ""
  Resume finally

End Sub

Answer 2

问题解决了！

由此：

    If key = Cells(i + 8, 2).Value Then
        ws.Cells(i + 8, week + 3).Value = CDbl(message)
        Exit For
    End If

对此：

    If key = Activities(i, 1) Then
        ws.Cells(i + 8, week + 3).Value = CDbl(message)
        Exit For
    End If

Excel VBA代码仅在调试模式下工作

2 个答案: