VBA conflicts with RTD (Real time data)

Nitil

New Member
Joined
May 8, 2021
Messages
5
Office Version
  1. 2019
Platform
  1. Windows
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,
 

Excel Facts

Excel Joke
Why can't spreadsheets drive cars? They crash too often!

Forum statistics

Threads
1,144,243
Messages
5,723,206
Members
422,484
Latest member
Yamasaki450

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top