LinkBack URL
About LinkBacksHi
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
Register To Reply
Bookmarks