Outlook 2016 зависает при работе Excel VBA - PullRequest
Новая
       11

Outlook 2016 зависает при работе Excel VBA

0 голосов
/ 22 мая 2019

Я использую версию 2016 года всех приложений MS Office.

У меня есть фрагмент кода, который занимает полчаса для запуска в Excel на одном листе. Пока код работает, Outlook не отвечает. Я попадаю в окно входящих сообщений, оно не выделяется серым цветом, говоря, что я не отвечаю, я просто не могу ничего щелкнуть.

Снятие отметок с библиотек OLE Automation и Microsoft Office 16.0 Object Library, как предлагалось в других публикациях, но это ни на что не повлияло 

Sub StartButton()
For Each ws In ActiveWorkbook.Worksheets

ws.Visible = xlSheetVisible

Next ws
starttime = Timer

Call ExtractTotals("Current", "Prov")
Call ExtractTotals("Previous", "Prov")
Call ExtractTotals("Current", "CCG")
Call ExtractTotals("Previous", "CCG")
Call ExtractWaitTimes("Current", "Prov")
Call ExtractWaitTimes("Previous", "Prov")
Call ExtractWaitTimes("Current", "CCG")
Call ExtractWaitTimes("Previous", "CCG")

'Sheets("Current Year Main").Visible = xlSheetHidden
'Sheets("Previous Year Main").Visible = xlSheetHidden

MsgBox ("finished in " & CStr(Timer - starttime))
End Sub



Sub ExtractTotals(year As String, level As String)

Application.ScreenUpdating = False
Sheets(year & " Year Main").Select
Cells(1, 1).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Sheets(year & " Year " & level & " Totals").Select
Cells(1, 1).Select
ActiveSheet.Paste

i = 2
j = 2
Do Until Len(Sheets(year & " Year Main").Cells(i, 1)) = 0
Sheets(year & " Year Main").Select
If level = "Prov" Then
    strlevel = "Provider"
ElseIf level = "CCG" Then
    strlevel = "CCG"
End If
    If Cells(i, 1) = strlevel And Cells(i, 4) = "Total" Then
        Cells(i, 1).Select
        Range(Selection, Selection.End(xlToRight)).Select
        Selection.Copy
        Sheets(year & " Year " & level & " Totals").Select
        Cells(j, 1).Select
        ActiveSheet.Paste
        j = j + 1
        i = i + 1
    Else
        i = i + 1
    End If
Loop
Sheets(year & " year " & level & " Totals").Visible = xlSheetHidden
Application.ScreenUpdating = True

End Sub




Sub ExtractWaitTimes(year As String, level As String)


Application.ScreenUpdating = False
Sheets(year & " Year " & level & " W Times").Cells.Clear
Sheets(year & " Year Main").Select
Cells(1, 1).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Sheets(year & " Year " & level & " W Times").Select
Cells(1, 1).Select
ActiveSheet.Paste

i = 2
j = 2
Do Until Len(Sheets(year & " Year Main").Cells(i, 1)) = 0
Sheets(year & " Year Main").Select

If level = "Prov" Then
    strlevel = "Provider"
ElseIf level = "CCG" Then
    strlevel = "CCG"
End If


If Cells(i, 1) = strlevel And Cells(i, 4) = "Waiting Time" Then
    Cells(i, 1).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Copy
    Sheets(year & " Year " & level & " W Times").Select
    Cells(j, 1).Select
    ActiveSheet.Paste
    j = j + 1
    i = i + 1
Else
    i = i + 1
End If
Loop
Sheets(year & " year " & level & " W Times").Visible = xlSheetHidden
Application.ScreenUpdating = True

End Sub
...