VBA Ожидание обновления запроса мощности для выполнения следующей строки кода - PullRequest
Новая
       32

VBA Ожидание обновления запроса мощности для выполнения следующей строки кода

0 голосов
/ 19 ноября 2018

Я работаю над проектом VBA, который требует обновления определенной таблицы с помощью запроса мощности как части кода. Обновление запроса мощности кода должно завершиться, прежде чем запрос продолжится, но мне пока не удалось найти решение, чтобы сделать это. 

Option Explicit
Option Base 1


Public Sub LoadProductsForecast()

Я вставил пару шагов для оптимизации производительности 

'Deactivate global application parameters to optimise code performance
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayStatusBar = False


'Dimensions used in code for sheets etc.
Dim lastrow As Integer
Dim NoRowsInitial As Integer


''''''''''''''''''''''
''Get product data, and copy index match formula to look up the forecast

' find number of rows to use for clearing
NoRowsInitial = WorksheetFunction.CountA(Worksheets("Monthly Forecast").Range("D4:D15000"))

'Selecting Worksheet w. product master data
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ActiveWorkbook
Set ws = Sheets("Products")
wb.Activate
ws.Select

В следующей строке я хочу обновить запрос мощности, и часть обновления работает как надо. Тем не менее, он продолжает выполнение следующего кода VBA. Я искал разные ответы в Интернете, и некоторые из них ссылаются на «DoEvents», однако, похоже, это не имеет значения. 

ActiveWorkbook.Connections("Query - tblAdjustments").Refresh
DoEvents

Ниже приведен оставшийся код, который должен запускаться после обновления таблицы PowerQuery: 

'Calculating number of rows to copy
lastrow = WorksheetFunction.CountA(Worksheets("Products").Range("B4:B15000"))

'Copying rows
Worksheets("Products").Range(Cells(4, 2), Cells(lastrow + 3, 10)).Copy

'Selecring forecast sheet
Set ws = Sheets("Monthly Forecast")
ws.Select

'Disabling alerts, so pop up for pasting data does not show (activated again later)
Application.DisplayAlerts = False

'Pasting product master data
Worksheets("Monthly Forecast").Range(Cells(8, 4), Cells(lastrow, 12)).PasteSpecial


'Creating a string that contains range to paste formula in to
Dim RangeString As String
RangeString = "N8:W" & lastrow + 7

'Copying formula to paste
    Range("AJ2:AJ3").Select
    Selection.Copy

'Pasting formula that looks up baseline FC (both seasonal and SES)
    Range(RangeString).Select
    ActiveSheet.Paste

Calculate

With Range(RangeString)
    .Value = .Value
End With

'Activating alerts again
Application.DisplayAlerts = True



''''''''''''''''''''''
''Code to clean the rows that are not used
'Remove unescessary rows


Dim NPIProducts As Integer
NPIProducts = [tblNewProd].Rows.Count


'tbl.Range.Rows.Count



Dim RowsToDelete As String

RowsToDelete = lastrow + NPIProducts * 2 & ":" & NoRowsInitial

If Left(RowsToDelete, 1) = "-" Then
    'do nothing (negative)
Else
    [tblMonthly].Rows(RowsToDelete).Delete
End If


'''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''
''''End of main code

'Activate global application parameters again
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.DisplayStatusBar = True


'Messages end user that the calculation is done
MsgBox "Load of products and forecast finished"

End Sub

Ответы [ 3 ]

0 голосов
/ 19 ноября 2018

Если вы этого еще не сделали, отключите фоновое обновление для запроса (плюс любые запросы, предшествующие этому запросу в цепочке оценки).

Вы хотите убедиться, что опция фонового обновления не отмечена. Я получил доступ к этому окну, щелкнув правой кнопкой мыши запрос и затем щелкнув Properties. Я думаю, что в некоторых других версиях Excel вам может потребоваться перейти к Data > Connections, найти запрос в списке и затем отредактировать его свойства там.

enter image description here

0 голосов
/ 19 ноября 2018

Если ваше соединение OLEDB или ODBC, вы можете временно установить для фонового обновления значение false - принудительное выполнение обновления до продолжения работы кода.Вместо вызова

.Connections("Query - tblAdjustments").Refresh

сделайте что-то вроде этого: 

Dim bRfresh As Boolean

    With ThisWorkbook.Connections("Query - tblAdjustments").OLEDBConnection
        bRfresh = .BackgroundQuery
        .BackgroundQuery = False
        .Refresh
        .BackgroundQuery = bRfresh

    End With

В этом примере предполагается, что у вас есть соединение OLEDB.Если у вас был ODBC, просто замените OLEDBConnection на ODBCConnection

0 голосов
/ 19 ноября 2018

Это не проверено, но теоретически это должно работать.
Разделите ваш код на две части.

Первая часть заканчивается обновлением.

sub some_sub()  
    'Deactivate global application parameters to optimise code performance
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.DisplayStatusBar = False


    'Dimensions used in code for sheets etc.
    Dim lastrow As Integer
    Dim NoRowsInitial As Integer


    ''''''''''''''''''''''
    ''Get product data, and copy index match formula to look up the forecast

    ' find number of rows to use for clearing
    NoRowsInitial = WorksheetFunction.CountA(Worksheets("Monthly Forecast").Range("D4:D15000"))

    'Selecting Worksheet w. product master data
    Dim wb As Workbook
    Dim ws As Worksheet
    Set wb = ActiveWorkbook
    Set ws = Sheets("Products")
    wb.Activate
    ws.Select
    ActiveWorkbook.Connections("Query - tblAdjustments").Refresh
end sub

Затем, чтобы дождаться его финиша, мы позволяем завершить подпрограмму.

Затем мы разрешаем Excel запустить Worksheet_Change.
На листе: 

Private Sub Worksheet_Change(ByVal Target As Range)


 'Calculating number of rows to copy
    lastrow = WorksheetFunction.CountA(Worksheets("Products").Range("B4:B15000"))

    'Copying rows
    Worksheets("Products").Range(Cells(4, 2), Cells(lastrow + 3, 10)).Copy

    'Selecring forecast sheet
    Set ws = Sheets("Monthly Forecast")
    ws.Select

    'Disabling alerts, so pop up for pasting data does not show (activated again later)
    Application.DisplayAlerts = False

    'Pasting product master data
    Worksheets("Monthly Forecast").Range(Cells(8, 4), Cells(lastrow, 12)).PasteSpecial


    'Creating a string that contains range to paste formula in to
    Dim RangeString As String
    RangeString = "N8:W" & lastrow + 7

    'Copying formula to paste
        Range("AJ2:AJ3").Select
        Selection.Copy

    'Pasting formula that looks up baseline FC (both seasonal and SES)
        Range(RangeString).Select
        ActiveSheet.Paste

    Calculate

    With Range(RangeString)
        .Value = .Value
    End With

    'Activating alerts again
    Application.DisplayAlerts = True



    ''''''''''''''''''''''
    ''Code to clean the rows that are not used
    'Remove unescessary rows


    Dim NPIProducts As Integer
    NPIProducts = [tblNewProd].Rows.Count


    'tbl.Range.Rows.Count



    Dim RowsToDelete As String

    RowsToDelete = lastrow + NPIProducts * 2 & ":" & NoRowsInitial

    If Left(RowsToDelete, 1) = "-" Then
        'do nothing (negative)
    Else
        [tblMonthly].Rows(RowsToDelete).Delete
    End If


    '''''''''''''''''''''''''''''''''''''''''''''
    '''''''''''''''''''''''''''''''''''''''''''''
    '''''''''''''''''''''''''''''''''''''''''''''
    ''''End of main code

    'Activate global application parameters again
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.DisplayStatusBar = True


    'Messages end user that the calculation is done
    MsgBox "Load of products and forecast finished"
End Sub

Вы можете использовать Target, чтобы не запускать ее, если не хотите.Я предполагаю, что есть хотя бы одна ячейка, которая, как вы знаете, изменится.Установите цель там.

...