Hi Experts,
I am facing error of RTD (Real time data) is not updating when the excel sheet is open before RTD start updating i.e. before 9:00 AM, but when the same excel sheet is open after 9:00 AM, the excel works fine, also the RTD (Real time data) works fine.
May be VBA code conflicts with RTD (Real time data).
Can I request for your support to solve the problem.
Would really appreciate your valuable solution for the said problem.
Thank you,
Below is codes in 3 Modules:
Module 1
Option Explicit
Public Interval As Double
Enum Nws ' worksheet navigation (Sheet1)
' 267 (ex 206)
NwsFirstRow = 2 ' change to suit 3
NwsAvg1 = 3 ' change to suit (3 =column C)68
'NwsAvg2 = 22 ' undefined = 1 larger than preceding 19
NwsMax1 = 4 ' change to suit (5 =column E)72
NwsMin1 = 5 ' 73
'NwsMax2 = 23 ' change to suit (7 =column G)118
'NwsMin2 = 24 ' NwsMin2 must be the last column here defined 119
End Enum
Sub SetTimer()
Interval = Now + TimeValue("00:00:10") ' Set your interval here
Debug.Print Now
Application.OnTime Interval, "MyMacro" ' name the time & macro to run
End Sub
Sub StopTimer()
On Error Resume Next ' Avoid crash if Timer isn't running
Application.OnTime Earliesttime:=Interval, Procedure:="MyMacro", Schedule:=False
End Sub
Sub MyMacro()
Dim Rl As Long ' last used row in column A
Dim Arr As Variant ' read data from the worksheet
Dim R As Long ' loop counter: sheet rows
Dim Ra As Long ' array row number
Application.ScreenUpdating = False
'Macro code that you want to run.
With Workbooks("Macro Copy paste and Cut paste Testing 1.xlsm").Worksheets("Sheet1") ' Change name to suit
Rl = .Cells(.Rows.Count, "A").End(xlUp).Row
Arr = .Range(.Cells(NwsFirstRow, 1), .Cells(Rl, NwsMin1)).Value '.Cells(Rl, NwsMin2)).Value
For R = NwsFirstRow To Rl
Ra = R - NwsFirstRow + 1
RecordMinMax Arr(Ra, NwsAvg1), Arr(Ra, NwsMax1), .Cells(R, NwsMax1), True
RecordMinMax Arr(Ra, NwsAvg1), Arr(Ra, NwsMin1), .Cells(R, NwsMin1), False
' RecordMinMax Arr(Ra, NwsAvg2), Arr(Ra, NwsMax2), .Cells(R, NwsMax2), True
' RecordMinMax Arr(Ra, NwsAvg2), Arr(Ra, NwsMin2), .Cells(R, NwsMin2), False
Next R
End With
Application.ScreenUpdating = True
' enable this line of you want to save the change:-
'ThisWorkbook.Save
'Calls the timer macro so it can be run again at the next interval.
Call SetTimer
End Sub
Private Sub RecordMinMax(ByVal NewVal As Variant, _
OldVal As Variant, _
Target As Range, _
IsMax As Boolean)
' 267 (ex 206 - 01 Jul 2021)
With Target
If Not IsEmpty(OldVal) Then
If IsMax Then
NewVal = WorksheetFunction.Max(NewVal, OldVal)
Else
NewVal = WorksheetFunction.Min(NewVal, OldVal)
End If
End If
If NewVal <> OldVal Then .Value = NewVal
End With
End Sub
Module 2
Public StartTime As Date, StopTime As Date, NextTime As Date, Interval As Double
Sub TimerLogic()
Select Case Now
Case Is < StartTime 'if before start time, set as start time
NextTime = StartTime
Case Is >= StopTime 'if after stop time
StartTime = StartTime + 1 'set start and stop times for tomorrow tomorrow
StopTime = StopTime + 1 'run timer for tomorrow
NextTime = StartTime
Case Else 'if between times
NextTime = Now + 0.6 * Interval 'add 60% of interval (to be rounded to next later interval)
End Select
'round time to nearest next interval time
NextTime = Application.WorksheetFunction.MRound(NextTime, Interval)
Debug.Print "Next time set at: " & Now '### to demo
Debug.Print "Due (with interval and rounding)= " & NextTime '### to demo
Set_Timer (NextTime)
End Sub
Sub Set_Timer(NextTime As Date)
Application.OnTime NextTime, "MyATR"
End Sub
Sub SetStartTime()
StartTime = Date + TimeValue("09:00:00")
StopTime = Date + TimeValue("19:00:00")
Interval = TimeValue("00:00:20")
End Sub
Sub MyATR()
'
Application.ScreenUpdating = False
' copy from Sheet 1
With Workbooks("Macro Copy paste and Cut paste Testing 1.xlsm")
.Worksheets("Sheet1").Range("A2:C5").Copy
' paste to same rows in Report
.Worksheets("Report").Range("A39:C42").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
.Worksheets("Report").Range("A7:C42").Copy
.Worksheets("Report").Range("A3:C38").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
ThisWorkbook.Save
End With
Application.ScreenUpdating = True
'MsgBox "Data added to Report"
'ActiveWorkbook.Save
'Call macro_timer
Debug.Print "Done: " & Now
TimerLogic
End Sub
Sub Stop_Timer()
On Error Resume Next
Tstop = Now + TimeValue("00:00:10")
Application.OnTime Earliesttime:=Tstop, Procedure:="MyATR", Schedule:=False
End Sub
Module 3
Public StartTime As Date, StopTime As Date, NextTime As Date, Interval As Double
Sub TimerLogic1()
Select Case Now
Case Is < StartTime 'if before start time, set as start time
NextTime = StartTime
Case Is >= StopTime 'if after stop time
StartTime = StartTime + 1 'set start and stop times for tomorrow tomorrow
StopTime = StopTime + 1 'run timer for tomorrow
NextTime = StartTime
Case Else 'if between times
NextTime = Now + 0.6 * Interval 'add 60% of interval (to be rounded to next later interval)
End Select
'round time to nearest next interval time
NextTime = Application.WorksheetFunction.MRound(NextTime, Interval)
Debug.Print "Next time set at: " & Now '### to demo
Debug.Print "Due (with interval and rounding)= " & NextTime '### to demo
Set_Timer1 (NextTime)
End Sub
Sub Set_Timer1(NextTime As Date)
Application.OnTime NextTime, "Myclearmacro"
End Sub
Sub SetStartTime1()
StartTime = Date + TimeValue("09:00:00")
StopTime = Date + TimeValue("19:00:00")
Interval = TimeValue("00:00:30")
End Sub
Sub Myclearmacro()
Dim Rl As Long ' last used row in column A
Application.ScreenUpdating = False
With Workbooks("Macro Copy paste and Cut paste Testing 1.xlsm").Worksheets("Sheet1") ' Change name to suit
Rl = .Cells(.Rows.Count, "B").End(xlUp).Row
.Range(.Cells(NwsFirstRow, NwsMax1), .Cells(Rl, NwsMax1)).ClearContents
.Range(.Cells(NwsFirstRow, NwsMin1), .Cells(Rl, NwsMin1)).ClearContents
' .Range(.Cells(NwsFirstRow, NwsMax2), .Cells(Rl, NwsMax2)).ClearContents
'.Range(.Cells(NwsFirstRow, NwsMin2), .Cells(Rl, NwsMin2)).ClearContents
End With
Application.ScreenUpdating = True
' MySettimer
Debug.Print "Done: " & Now
TimerLogic1
End Sub
Sub Stop_Timer1()
On Error Resume Next
Tstop = Now + TimeValue("00:00:10")
Application.OnTime Earliesttime:=Tstop, Procedure:="Myclearmacro", Schedule:=False
End Sub
Regards,
I am facing error of RTD (Real time data) is not updating when the excel sheet is open before RTD start updating i.e. before 9:00 AM, but when the same excel sheet is open after 9:00 AM, the excel works fine, also the RTD (Real time data) works fine.
May be VBA code conflicts with RTD (Real time data).
Can I request for your support to solve the problem.
Would really appreciate your valuable solution for the said problem.
Thank you,
Below is codes in 3 Modules:
Module 1
Option Explicit
Public Interval As Double
Enum Nws ' worksheet navigation (Sheet1)
' 267 (ex 206)
NwsFirstRow = 2 ' change to suit 3
NwsAvg1 = 3 ' change to suit (3 =column C)68
'NwsAvg2 = 22 ' undefined = 1 larger than preceding 19
NwsMax1 = 4 ' change to suit (5 =column E)72
NwsMin1 = 5 ' 73
'NwsMax2 = 23 ' change to suit (7 =column G)118
'NwsMin2 = 24 ' NwsMin2 must be the last column here defined 119
End Enum
Sub SetTimer()
Interval = Now + TimeValue("00:00:10") ' Set your interval here
Debug.Print Now
Application.OnTime Interval, "MyMacro" ' name the time & macro to run
End Sub
Sub StopTimer()
On Error Resume Next ' Avoid crash if Timer isn't running
Application.OnTime Earliesttime:=Interval, Procedure:="MyMacro", Schedule:=False
End Sub
Sub MyMacro()
Dim Rl As Long ' last used row in column A
Dim Arr As Variant ' read data from the worksheet
Dim R As Long ' loop counter: sheet rows
Dim Ra As Long ' array row number
Application.ScreenUpdating = False
'Macro code that you want to run.
With Workbooks("Macro Copy paste and Cut paste Testing 1.xlsm").Worksheets("Sheet1") ' Change name to suit
Rl = .Cells(.Rows.Count, "A").End(xlUp).Row
Arr = .Range(.Cells(NwsFirstRow, 1), .Cells(Rl, NwsMin1)).Value '.Cells(Rl, NwsMin2)).Value
For R = NwsFirstRow To Rl
Ra = R - NwsFirstRow + 1
RecordMinMax Arr(Ra, NwsAvg1), Arr(Ra, NwsMax1), .Cells(R, NwsMax1), True
RecordMinMax Arr(Ra, NwsAvg1), Arr(Ra, NwsMin1), .Cells(R, NwsMin1), False
' RecordMinMax Arr(Ra, NwsAvg2), Arr(Ra, NwsMax2), .Cells(R, NwsMax2), True
' RecordMinMax Arr(Ra, NwsAvg2), Arr(Ra, NwsMin2), .Cells(R, NwsMin2), False
Next R
End With
Application.ScreenUpdating = True
' enable this line of you want to save the change:-
'ThisWorkbook.Save
'Calls the timer macro so it can be run again at the next interval.
Call SetTimer
End Sub
Private Sub RecordMinMax(ByVal NewVal As Variant, _
OldVal As Variant, _
Target As Range, _
IsMax As Boolean)
' 267 (ex 206 - 01 Jul 2021)
With Target
If Not IsEmpty(OldVal) Then
If IsMax Then
NewVal = WorksheetFunction.Max(NewVal, OldVal)
Else
NewVal = WorksheetFunction.Min(NewVal, OldVal)
End If
End If
If NewVal <> OldVal Then .Value = NewVal
End With
End Sub
Module 2
Public StartTime As Date, StopTime As Date, NextTime As Date, Interval As Double
Sub TimerLogic()
Select Case Now
Case Is < StartTime 'if before start time, set as start time
NextTime = StartTime
Case Is >= StopTime 'if after stop time
StartTime = StartTime + 1 'set start and stop times for tomorrow tomorrow
StopTime = StopTime + 1 'run timer for tomorrow
NextTime = StartTime
Case Else 'if between times
NextTime = Now + 0.6 * Interval 'add 60% of interval (to be rounded to next later interval)
End Select
'round time to nearest next interval time
NextTime = Application.WorksheetFunction.MRound(NextTime, Interval)
Debug.Print "Next time set at: " & Now '### to demo
Debug.Print "Due (with interval and rounding)= " & NextTime '### to demo
Set_Timer (NextTime)
End Sub
Sub Set_Timer(NextTime As Date)
Application.OnTime NextTime, "MyATR"
End Sub
Sub SetStartTime()
StartTime = Date + TimeValue("09:00:00")
StopTime = Date + TimeValue("19:00:00")
Interval = TimeValue("00:00:20")
End Sub
Sub MyATR()
'
Application.ScreenUpdating = False
' copy from Sheet 1
With Workbooks("Macro Copy paste and Cut paste Testing 1.xlsm")
.Worksheets("Sheet1").Range("A2:C5").Copy
' paste to same rows in Report
.Worksheets("Report").Range("A39:C42").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
.Worksheets("Report").Range("A7:C42").Copy
.Worksheets("Report").Range("A3:C38").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
ThisWorkbook.Save
End With
Application.ScreenUpdating = True
'MsgBox "Data added to Report"
'ActiveWorkbook.Save
'Call macro_timer
Debug.Print "Done: " & Now
TimerLogic
End Sub
Sub Stop_Timer()
On Error Resume Next
Tstop = Now + TimeValue("00:00:10")
Application.OnTime Earliesttime:=Tstop, Procedure:="MyATR", Schedule:=False
End Sub
Module 3
Public StartTime As Date, StopTime As Date, NextTime As Date, Interval As Double
Sub TimerLogic1()
Select Case Now
Case Is < StartTime 'if before start time, set as start time
NextTime = StartTime
Case Is >= StopTime 'if after stop time
StartTime = StartTime + 1 'set start and stop times for tomorrow tomorrow
StopTime = StopTime + 1 'run timer for tomorrow
NextTime = StartTime
Case Else 'if between times
NextTime = Now + 0.6 * Interval 'add 60% of interval (to be rounded to next later interval)
End Select
'round time to nearest next interval time
NextTime = Application.WorksheetFunction.MRound(NextTime, Interval)
Debug.Print "Next time set at: " & Now '### to demo
Debug.Print "Due (with interval and rounding)= " & NextTime '### to demo
Set_Timer1 (NextTime)
End Sub
Sub Set_Timer1(NextTime As Date)
Application.OnTime NextTime, "Myclearmacro"
End Sub
Sub SetStartTime1()
StartTime = Date + TimeValue("09:00:00")
StopTime = Date + TimeValue("19:00:00")
Interval = TimeValue("00:00:30")
End Sub
Sub Myclearmacro()
Dim Rl As Long ' last used row in column A
Application.ScreenUpdating = False
With Workbooks("Macro Copy paste and Cut paste Testing 1.xlsm").Worksheets("Sheet1") ' Change name to suit
Rl = .Cells(.Rows.Count, "B").End(xlUp).Row
.Range(.Cells(NwsFirstRow, NwsMax1), .Cells(Rl, NwsMax1)).ClearContents
.Range(.Cells(NwsFirstRow, NwsMin1), .Cells(Rl, NwsMin1)).ClearContents
' .Range(.Cells(NwsFirstRow, NwsMax2), .Cells(Rl, NwsMax2)).ClearContents
'.Range(.Cells(NwsFirstRow, NwsMin2), .Cells(Rl, NwsMin2)).ClearContents
End With
Application.ScreenUpdating = True
' MySettimer
Debug.Print "Done: " & Now
TimerLogic1
End Sub
Sub Stop_Timer1()
On Error Resume Next
Tstop = Now + TimeValue("00:00:10")
Application.OnTime Earliesttime:=Tstop, Procedure:="Myclearmacro", Schedule:=False
End Sub
Regards,
