Excel2000 VBA: How force the procedure to wait until queries are refreshed?

A

Arvi Laanemets

Hi

The procedure below must delete all data from a table, which have given
dates, refresh two queries based on this table, and recalculate some values
(last and previous price for item in data table, and the difference)
adjacent to one of query tables. The problem is, that the code don't wait
until queries are refreshed - as result recalculated values will be wrong,
or - when the number of different dates in table will be less than 2 - the
procedure stops with error. I tried to use Application.Wait, but it didn't
help (the waiting time was ~1 - 5 minutes, depending on number of rows in
data table).

How can I test, are queries finished refreshing, and to continue with code
after that?

Thanks in advance!
--
Arvi Laanemets
( My real mail address: arvil<at>tarkon.ee )



********

Public Sub DeleData()
' Status bar text
oldstatusbar = Application.DisplayStatusBar
Application.DisplayStatusBar = True

' Ask for date which data are deleted
varDate = CDate(InputBox("Insert a date (in format 'dd.mm.yyyy') to be
deleted!"))

' Check for presence of data for same date in summary workbook
If ThisWorkbook.Sheets("Data").UsedRange.Find(varDate) Is Nothing Then
varMsg = MsgBox("No data for this date exist in table!", vbOKOnly)
Else
varMsg = MsgBox("Are you sure you want to delete all data for " &
Format(varDate, "dd.mm.yyyy") & "?", vbOKCancel)
If varMsg = 1 Then
varContinue = True
Application.StatusBar = "Deleting data with selected date ..."
varRow1 = Application.WorksheetFunction.Match(CLng(varDate),
[DataDate], 0) + 1
varRow2 = varRow1 +
Application.WorksheetFunction.CountIf([DataDate], CDate(varDate)) - 1
ThisWorkbook.Sheets("Data").Rows(varRow1 & ":" & varRow2).Delete
Shift:=xlUp
End If
End If
If varContinue Then

' Redefine summary data table
varSummaryRows = [DataRows]
ThisWorkbook.Names("DataTbl").RefersTo = "=Data!$B$1:$H$" &
varSummaryRows

' Refresh Article list
' The query creates an unique article list from DataTbl, containing
columns
' Article, ArticleDescription, LEFT(Article) As Group
Application.StatusBar = "Refreshing Article list ..."
Set qtQtrResults = Worksheets("Articles").QueryTables(1)
ThisWorkbook.Sheets("Articles").Activate
ActiveSheet.Range("A1").Select
With qtQtrResults
.CommandType = xlCmdSql
.Refresh
End With

' Refresh Dates list

' The query creates an unique dates list from DataTbl, containing
column Date
Application.StatusBar = "Refreshing Dates list ..."
Set qtQtrResults = Worksheets("Dates").QueryTables(1)
ThisWorkbook.Sheets("Dates").Activate
ActiveSheet.Range("A1").Select
With qtQtrResults
.CommandType = xlCmdSql
.Refresh
End With

' ***** Here is my attempt to find a solution *****
' Wait some time for queries and calculations to be finished
WaitTime = "0:" & _
Format(IIf(Int(varSummaryRows / (50 * 60)) < 2,
Int(varSummaryRows / (50 * 60)), 5), "00") & _
":" & Format(Int((varSummaryRows Mod 50 * 60) / 50), "00")
Application.StatusBar = "Waiting " & WaitTime & " for queries to be
finished ..."
Application.Wait (Now + TimeValue(WaitTime))

' Recalculate articles last prices
Application.StatusBar = "Recalculating last prices in article list
...."
varArtRows = [ArtRows]
ThisWorkbook.Sheets("Data").Activate
For i = 2 To varArtRows
If ThisWorkbook.Sheets("Articles").Range("A" & i).Value = ""
Then
ThisWorkbook.Sheets("Articles").Range(i & ":" & i).Delete
Shift:=xlUp
i = i - 1
Else
varArt = ThisWorkbook.Sheets("Articles").Range("A" &
i).Value
varPrevPrice = ""
varLastPrice = ""
varDiff = ""

If [PrevDate] <> "" Then
' PrevDate is a named range defined as
<=IF(ISERROR(LARGE(DatesList;2));"";LARGE(DatesList;2)) >
' DatesList is a named range defined as
<=OFFSET(Dates!$A$1;1;;COUNTIF(Dates!$A:$A;"<>")-1;1) >
' ***** Here goes it wrong way. P.e. when PrevDate was <>
"", but must now be = "", the IF is processed
' The named range PrevStart (row number of 1st occurrence of
PrevDate) has been refreshed at this time,
' and instead of row number returns "" - so
ActiveSheet.Range returns an error.
y = ThisWorkbook.Sheets("Data").UsedRange.Find(varArt,
ActiveSheet.Range("A" & [PrevStart]), xlValues, xlWhole).Row
If ThisWorkbook.Sheets("Data").Range("A" &
[PrevStart]).Value = ThisWorkbook.Sheets("Data").Range("A" & y).Value Then
varPrevPrice = ThisWorkbook.Sheets("Data").Range("E"
& y).Value
End If
End If

If [LastDate] <> "" Then
' ***** Similar with previous IF, but presence of last date
data is checked
y = ThisWorkbook.Sheets("Data").UsedRange.Find(varArt,
ActiveSheet.Range("A" & [LastStart]), xlValues, xlWhole).Row
If ThisWorkbook.Sheets("Data").Range("A" &
[LastStart]).Value = ThisWorkbook.Sheets("Data").Range("A" & y).Value Then
varLastPrice = ThisWorkbook.Sheets("Data").Range("E"
& y).Value
End If
End If

If varPrevPrice <> "" And varLastPrice <> "" Then
varDiff = varLastPrice - varPrevPrice
End If

ThisWorkbook.Sheets("Articles").Range("D" & i).Value =
varPrevPrice
ThisWorkbook.Sheets("Articles").Range("E" & i).Value =
varLastPrice
ThisWorkbook.Sheets("Articles").Range("F" & i).Value =
varDiff
End If
Next i
End If
Application.StatusBar = "Done ..."
' Restore status bar
Application.StatusBar = False
Application.DisplayStatusBar = oldstatusbar
ThisWorkbook.Sheets("Report").Activate
End Sub
 
K

K Dales

Two possibilities: set the querytable so it does NOT do background refreshing
- forces Excel to wait for it to finish:
qtQtrResults.BackgroundQuery = False

Or, to ensure it is done refreshing before continuing:
With qtQtrResults
.CommandType = xlCmdSql
.Refresh
While .Refreshing
' Display a message here, e.g., Please wait... query refreshing
DoEvents
Wend
End With

- This would eliminate your need for a time delay (which is not really a
good option, since there are factors out of your control that will affect the
time it takes the query to process)

Arvi Laanemets said:
Hi

The procedure below must delete all data from a table, which have given
dates, refresh two queries based on this table, and recalculate some values
(last and previous price for item in data table, and the difference)
adjacent to one of query tables. The problem is, that the code don't wait
until queries are refreshed - as result recalculated values will be wrong,
or - when the number of different dates in table will be less than 2 - the
procedure stops with error. I tried to use Application.Wait, but it didn't
help (the waiting time was ~1 - 5 minutes, depending on number of rows in
data table).

How can I test, are queries finished refreshing, and to continue with code
after that?

Thanks in advance!
--
Arvi Laanemets
( My real mail address: arvil<at>tarkon.ee )



********

Public Sub DeleData()
' Status bar text
oldstatusbar = Application.DisplayStatusBar
Application.DisplayStatusBar = True

' Ask for date which data are deleted
varDate = CDate(InputBox("Insert a date (in format 'dd.mm.yyyy') to be
deleted!"))

' Check for presence of data for same date in summary workbook
If ThisWorkbook.Sheets("Data").UsedRange.Find(varDate) Is Nothing Then
varMsg = MsgBox("No data for this date exist in table!", vbOKOnly)
Else
varMsg = MsgBox("Are you sure you want to delete all data for " &
Format(varDate, "dd.mm.yyyy") & "?", vbOKCancel)
If varMsg = 1 Then
varContinue = True
Application.StatusBar = "Deleting data with selected date ..."
varRow1 = Application.WorksheetFunction.Match(CLng(varDate),
[DataDate], 0) + 1
varRow2 = varRow1 +
Application.WorksheetFunction.CountIf([DataDate], CDate(varDate)) - 1
ThisWorkbook.Sheets("Data").Rows(varRow1 & ":" & varRow2).Delete
Shift:=xlUp
End If
End If
If varContinue Then

' Redefine summary data table
varSummaryRows = [DataRows]
ThisWorkbook.Names("DataTbl").RefersTo = "=Data!$B$1:$H$" &
varSummaryRows

' Refresh Article list
' The query creates an unique article list from DataTbl, containing
columns
' Article, ArticleDescription, LEFT(Article) As Group
Application.StatusBar = "Refreshing Article list ..."
Set qtQtrResults = Worksheets("Articles").QueryTables(1)
ThisWorkbook.Sheets("Articles").Activate
ActiveSheet.Range("A1").Select
With qtQtrResults
.CommandType = xlCmdSql
.Refresh
End With

' Refresh Dates list

' The query creates an unique dates list from DataTbl, containing
column Date
Application.StatusBar = "Refreshing Dates list ..."
Set qtQtrResults = Worksheets("Dates").QueryTables(1)
ThisWorkbook.Sheets("Dates").Activate
ActiveSheet.Range("A1").Select
With qtQtrResults
.CommandType = xlCmdSql
.Refresh
End With

' ***** Here is my attempt to find a solution *****
' Wait some time for queries and calculations to be finished
WaitTime = "0:" & _
Format(IIf(Int(varSummaryRows / (50 * 60)) < 2,
Int(varSummaryRows / (50 * 60)), 5), "00") & _
":" & Format(Int((varSummaryRows Mod 50 * 60) / 50), "00")
Application.StatusBar = "Waiting " & WaitTime & " for queries to be
finished ..."
Application.Wait (Now + TimeValue(WaitTime))

' Recalculate articles last prices
Application.StatusBar = "Recalculating last prices in article list
...."
varArtRows = [ArtRows]
ThisWorkbook.Sheets("Data").Activate
For i = 2 To varArtRows
If ThisWorkbook.Sheets("Articles").Range("A" & i).Value = ""
Then
ThisWorkbook.Sheets("Articles").Range(i & ":" & i).Delete
Shift:=xlUp
i = i - 1
Else
varArt = ThisWorkbook.Sheets("Articles").Range("A" &
i).Value
varPrevPrice = ""
varLastPrice = ""
varDiff = ""

If [PrevDate] <> "" Then
' PrevDate is a named range defined as
<=IF(ISERROR(LARGE(DatesList;2));"";LARGE(DatesList;2)) >
' DatesList is a named range defined as
<=OFFSET(Dates!$A$1;1;;COUNTIF(Dates!$A:$A;"<>")-1;1) >
' ***** Here goes it wrong way. P.e. when PrevDate was <>
"", but must now be = "", the IF is processed
' The named range PrevStart (row number of 1st occurrence of
PrevDate) has been refreshed at this time,
' and instead of row number returns "" - so
ActiveSheet.Range returns an error.
y = ThisWorkbook.Sheets("Data").UsedRange.Find(varArt,
ActiveSheet.Range("A" & [PrevStart]), xlValues, xlWhole).Row
If ThisWorkbook.Sheets("Data").Range("A" &
[PrevStart]).Value = ThisWorkbook.Sheets("Data").Range("A" & y).Value Then
varPrevPrice = ThisWorkbook.Sheets("Data").Range("E"
& y).Value
End If
End If

If [LastDate] <> "" Then
' ***** Similar with previous IF, but presence of last date
data is checked
y = ThisWorkbook.Sheets("Data").UsedRange.Find(varArt,
ActiveSheet.Range("A" & [LastStart]), xlValues, xlWhole).Row
If ThisWorkbook.Sheets("Data").Range("A" &
[LastStart]).Value = ThisWorkbook.Sheets("Data").Range("A" & y).Value Then
varLastPrice = ThisWorkbook.Sheets("Data").Range("E"
& y).Value
End If
End If

If varPrevPrice <> "" And varLastPrice <> "" Then
varDiff = varLastPrice - varPrevPrice
End If

ThisWorkbook.Sheets("Articles").Range("D" & i).Value =
varPrevPrice
ThisWorkbook.Sheets("Articles").Range("E" & i).Value =
varLastPrice
ThisWorkbook.Sheets("Articles").Range("F" & i).Value =
varDiff
End If
Next i
End If
Application.StatusBar = "Done ..."
' Restore status bar
Application.StatusBar = False
Application.DisplayStatusBar = oldstatusbar
ThisWorkbook.Sheets("Report").Activate
End Sub
Click to expand...
 
A

Arvi Laanemets

Hi

I got 3rd possibility too meanwhile from Dr. Eckehard Pfeifer
(microsoft.public.de.excel) - to use AfterRefresh events of queries. As much
as I can decide, part of code remains in procedure, then the 1st query is
started, after this query is refreshed, in AfterRefresh the second one is
started, and in AtherRefresh of 3nd query the rest of code is processed.

Tomorrow I´ll try all those solutions out.


Arvi Laanemets


K Dales said:
Two possibilities: set the querytable so it does NOT do background refreshing
- forces Excel to wait for it to finish:
qtQtrResults.BackgroundQuery = False

Or, to ensure it is done refreshing before continuing:
With qtQtrResults
.CommandType = xlCmdSql
.Refresh
While .Refreshing
' Display a message here, e.g., Please wait... query refreshing
DoEvents
Wend
End With

- This would eliminate your need for a time delay (which is not really a
good option, since there are factors out of your control that will affect the
time it takes the query to process)

Arvi Laanemets said:
Hi

The procedure below must delete all data from a table, which have given
dates, refresh two queries based on this table, and recalculate some values
(last and previous price for item in data table, and the difference)
adjacent to one of query tables. The problem is, that the code don't wait
until queries are refreshed - as result recalculated values will be wrong,
or - when the number of different dates in table will be less than 2 - the
procedure stops with error. I tried to use Application.Wait, but it didn't
help (the waiting time was ~1 - 5 minutes, depending on number of rows in
data table).

How can I test, are queries finished refreshing, and to continue with code
after that?

Thanks in advance!
--
Arvi Laanemets
( My real mail address: arvil<at>tarkon.ee )



********

Public Sub DeleData()
' Status bar text
oldstatusbar = Application.DisplayStatusBar
Application.DisplayStatusBar = True

' Ask for date which data are deleted
varDate = CDate(InputBox("Insert a date (in format 'dd.mm.yyyy') to be
deleted!"))

' Check for presence of data for same date in summary workbook
If ThisWorkbook.Sheets("Data").UsedRange.Find(varDate) Is Nothing Then
varMsg = MsgBox("No data for this date exist in table!", vbOKOnly)
Else
varMsg = MsgBox("Are you sure you want to delete all data for " &
Format(varDate, "dd.mm.yyyy") & "?", vbOKCancel)
If varMsg = 1 Then
varContinue = True
Application.StatusBar = "Deleting data with selected date ...."
varRow1 = Application.WorksheetFunction.Match(CLng(varDate),
[DataDate], 0) + 1
varRow2 = varRow1 +
Application.WorksheetFunction.CountIf([DataDate], CDate(varDate)) - 1
ThisWorkbook.Sheets("Data").Rows(varRow1 & ":" & varRow2).Delete
Shift:=xlUp
End If
End If
If varContinue Then

' Redefine summary data table
varSummaryRows = [DataRows]
ThisWorkbook.Names("DataTbl").RefersTo = "=Data!$B$1:$H$" &
varSummaryRows

' Refresh Article list
' The query creates an unique article list from DataTbl, containing
columns
' Article, ArticleDescription, LEFT(Article) As Group
Application.StatusBar = "Refreshing Article list ..."
Set qtQtrResults = Worksheets("Articles").QueryTables(1)
ThisWorkbook.Sheets("Articles").Activate
ActiveSheet.Range("A1").Select
With qtQtrResults
.CommandType = xlCmdSql
.Refresh
End With

' Refresh Dates list

' The query creates an unique dates list from DataTbl, containing
column Date
Application.StatusBar = "Refreshing Dates list ..."
Set qtQtrResults = Worksheets("Dates").QueryTables(1)
ThisWorkbook.Sheets("Dates").Activate
ActiveSheet.Range("A1").Select
With qtQtrResults
.CommandType = xlCmdSql
.Refresh
End With

' ***** Here is my attempt to find a solution *****
' Wait some time for queries and calculations to be finished
WaitTime = "0:" & _
Format(IIf(Int(varSummaryRows / (50 * 60)) < 2,
Int(varSummaryRows / (50 * 60)), 5), "00") & _
":" & Format(Int((varSummaryRows Mod 50 * 60) / 50), "00")
Application.StatusBar = "Waiting " & WaitTime & " for queries to be
finished ..."
Application.Wait (Now + TimeValue(WaitTime))

' Recalculate articles last prices
Application.StatusBar = "Recalculating last prices in article list
...."
varArtRows = [ArtRows]
ThisWorkbook.Sheets("Data").Activate
For i = 2 To varArtRows
If ThisWorkbook.Sheets("Articles").Range("A" & i).Value = ""
Then
ThisWorkbook.Sheets("Articles").Range(i & ":" & i).Delete
Shift:=xlUp
i = i - 1
Else
varArt = ThisWorkbook.Sheets("Articles").Range("A" &
i).Value
varPrevPrice = ""
varLastPrice = ""
varDiff = ""

If [PrevDate] <> "" Then
' PrevDate is a named range defined as
<=IF(ISERROR(LARGE(DatesList;2));"";LARGE(DatesList;2)) >
' DatesList is a named range defined as
<=OFFSET(Dates!$A$1;1;;COUNTIF(Dates!$A:$A;"<>")-1;1) >
' ***** Here goes it wrong way. P.e. when PrevDate was
Click to expand...
"", but must now be = "", the IF is processed
' The named range PrevStart (row number of 1st occurrence of
PrevDate) has been refreshed at this time,
' and instead of row number returns "" - so
ActiveSheet.Range returns an error.
y = ThisWorkbook.Sheets("Data").UsedRange.Find(varArt,
ActiveSheet.Range("A" & [PrevStart]), xlValues, xlWhole).Row
If ThisWorkbook.Sheets("Data").Range("A" &
[PrevStart]).Value = ThisWorkbook.Sheets("Data").Range("A" & y).Value Then
varPrevPrice = ThisWorkbook.Sheets("Data").Range("E"
& y).Value
End If
End If

If [LastDate] <> "" Then
' ***** Similar with previous IF, but presence of last date
data is checked
y = ThisWorkbook.Sheets("Data").UsedRange.Find(varArt,
ActiveSheet.Range("A" & [LastStart]), xlValues, xlWhole).Row
If ThisWorkbook.Sheets("Data").Range("A" &
[LastStart]).Value = ThisWorkbook.Sheets("Data").Range("A" & y).Value Then
varLastPrice = ThisWorkbook.Sheets("Data").Range("E"
& y).Value
End If
End If

If varPrevPrice <> "" And varLastPrice <> "" Then
varDiff = varLastPrice - varPrevPrice
End If

ThisWorkbook.Sheets("Articles").Range("D" & i).Value =
varPrevPrice
ThisWorkbook.Sheets("Articles").Range("E" & i).Value =
varLastPrice
ThisWorkbook.Sheets("Articles").Range("F" & i).Value =
varDiff
End If
Next i
End If
Application.StatusBar = "Done ..."
' Restore status bar
Application.StatusBar = False
Application.DisplayStatusBar = oldstatusbar
ThisWorkbook.Sheets("Report").Activate
End Sub
Click to expand...
Click to expand...
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Unable to set the active cell from within a VBA procedure 1

Top