Code executing Twice each time it's called...

**KjBox** · May 1st 2019

Try the attached version.

I have changed the code so that the Check1 sub is called when cell C2 on Sheet1 changes.

Code in Sheet1 Worksheet Object Module is

Code

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, [c2]) Is Nothing Then check1
End Sub

I also redid your Check1 code, it is now

Code

Sub check1()
    Dim lRow As Long
    
    Application.ScreenUpdating = 0
    With Sheets("Sheet1").Cells(1).CurrentRegion
        With .Offset(4).Resize(.Rows.Count - 4, 16)
            .Sort .Columns(1)
        End With
        x = .Value2
    End With
    With Sheets("race1")
        If .[a61] = vbNullString Then
            lRow = 61
        Else
            lRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 15 - .[c20]
        End If
        .Cells(lRow, 1).Resize(UBound(x, 1), UBound(x, 2)) = x
        .Activate
        ActiveWindow.ScrollColumn = 1
        ActiveWindow.ScrollRow = lRow
    End With
    
End Sub

Display More

hanley1992 · May 1st 2019

Hi Kj, Thanks for all your efforts with this, that check1 code looks very slick indeed.

Unfortunately it isn't taking the schedule times into account in 'race1' (D1 to L1), as soon as the feed comes in no matter what time it is it fires up check 1 every second , the pasting is going in exactly the right places but the schedule times are in effect redundant.

**KjBox** · May 1st 2019

So the feed is updating sheet1 every second?

If so, then you need check1 to run when the time in C2 of the updated Sheet1 data matches a time in race1 D1:L1. Is that correct?

hanley1992 · May 1st 2019

Yes that's correct sheet1 will be updating depending on the API setting which currently is set to 1 second.

And yes spot on i only want to fire up check1 when C2 matches any of the schedule times in those cells on race 1 (D1:L1).That would be exactly what's required.

I

**KjBox** · May 1st 2019

OK try this version then.

I have made the range D1:L1 a named range (named "Times"), and the Sheet1 Worksheet Object Module code is changed to

Code

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not IsError(Application.Match([c2], [Times], 0)) Then check1
End Sub

**KjBox** · May 1st 2019

If you still need the Update button then you need to change the code assigned to that button to

Code

Private Sub CommandButton2_Click()
    If Not IsError(Application.Match([a21], [Times], 0)) Then check1
End Sub

hanley1992 · May 1st 2019

It's waiting for the schedule times and guess what Kj, it's firing the macro twice again! like it did in the initial code (your code is obviously immeasurably better).

Is this stuff in 'thisworkbook' as Carim suggested earlier a potential problem?

I'm not even sure if it's doing anything, I have totally reworked this book from what it used to be. (it was a book initially coded by associates of the ApI but it was awful for my needs.

**KjBox** · May 1st 2019

Try changing the worksheet change code to

Code

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not IsError(Application.Match([c2], [Times], 0)) Then
        Application.EnableEvents = 0
        check1
        Application.EnableEvents = 1
    End If
End Sub

**KjBox** · May 1st 2019

Yes, you should move those 2 routines out of ThisWorkbook and into a standard module, as Carim showed in the file he attached.

hanley1992 · May 1st 2019

I updated that code into sheet1, it's still pasting twice KJ.

**KjBox** · May 1st 2019

Only pasting once for me! Make sure the Workshhet_Calculate code has been removed from the race1 Worksheet Object Module.

hanley1992 · May 1st 2019

Can I please repost this book back to you because I have become totally and utterly lost with all the changes and folders and carim's version etc etc. I really have tried to follow but I'm not sure now what should be where, I'm so sorry.

hanley1992 · May 1st 2019

I was obviously very close to the solution KJ as you reached it. From the double posting problem, i have tried to follow all the changes on here and also update your sheet with Carim's changes (to thisworkbook code) but am now actually managing to get error messages in check 1.

Here is all the code I have in my book now, If you could have a look and see what is going wrong I would be most grateful.

HTML

Option Explicit
Dim NextTime As Double
Sub check1()
    Dim lRow As Long
    
    Application.ScreenUpdating = 0
    With Sheets("Sheet1").Cells(1).CurrentRegion
        With .Offset(4).Resize(.Rows.Count - 4, 16)
            .Sort .Columns(1)
        End With
        x = .Value2
    End With
    With Sheets("race1")
        If .[a61] = vbNullString Then
            lRow = 61
        Else
            lRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 15 - .[c20]
        End If
        .Cells(lRow, 1).Resize(UBound(x, 1), UBound(x, 2)) = x
        .Columns(1).AutoFit
        .Activate
        ActiveWindow.ScrollColumn = 1
        ActiveWindow.ScrollRow = lRow
    End With
    
End Sub
Sub formatrace()
'
' formatrace Macro
'


'
    Columns("E:E").Select
    Selection.Replace What:="(*)", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Columns("K:K").Select
    Selection.Copy
    Columns("E:E").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Columns("C:I").Select
    ActiveWorkbook.Worksheets("tjo").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("tjo").Sort.SortFields.Add Key:=Range("C2:C1000"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("tjo").Sort.SortFields.Add Key:=Range("D2:D1000"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("tjo").Sort.SortFields.Add Key:=Range("E2:E1000"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("tjo").Sort
        .SetRange Range("C1:I1000")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub
Sub RecordData()
Dim Interval As Double, cel As Range, Capture As Range
Interval = 5 'Number of seconds between each recording of dataSet Capture = Worksheets("Sheet1").Range("A1:A5") 'Capture this column of data
With Worksheets("Sheet2") 'Record the data on this worksheet
    Set cel = .Range("A2") 'First timestamp goes here
    Set cel = .Cells(.Rows.Count, cel.Column).End(xlUp).Offset(1, 0): cel.Value = Now
    cel.Offset(0, 1).Resize(1, Capture.Cells.Count).Value = Application.Transpose(Capture.Value)
End With
NextTime = Now + Interval / 86400
Application.OnTime NextTime, "RecordData"
End Sub
 
Sub StopRecordingData()
On Error Resume Next
Application.OnTime NextTime, "RecordData", , False
On Error GoTo 0
End Sub

Display More

Sheet1

HTML

Option Explicit


Private Sub Worksheet_Change(ByVal Target As Range)
    If Not IsError(Application.Match([c2], [Times], 0)) Then
        Application.EnableEvents = 0
        check1
        Application.EnableEvents = 1
    End If
End Sub

Sheet3(race1)

HTML

Option Explicit


Private Sub CommandButton1_Click()
    Worksheets("race1").Activate
    Range("d5:j5").ClearContents
    Range("d5").Activate
End Sub


Private Sub CommandButton2_Click()
    check1
End Sub

Display More

Sheet5(tjo)

HTML

Option Explicit


Private Sub CommandButton1_Click()
formatrace


End Sub


Private Sub CommandButton2_Click()
Worksheets("tjo").Activate
Range("c1:j1000").ClearContents
ThisWorkbook.Sheets("tjo").Range("l1").Select
End Sub

Display More

Thisworkbook

HTML

Option Explicit


'This code should go in a regular module sheet, and won't work properly if installed anywhere else. _
   The next (Dim) statement must occur before any subs or functions.

hanley1992 · May 1st 2019

The first block label didn't post for some reason * all the code from module 1

hanley1992 · May 1st 2019

I got rid of the many versions of this sheet and downloaded version 2.2 again which has the following...

MODULE 1

HTML

Sub check1()
    Dim lRow As Long
    
    Application.ScreenUpdating = 0
    With Sheets("Sheet1").Cells(1).CurrentRegion
        With .Offset(4).Resize(.Rows.Count - 4, 16)
            .Sort .Columns(1)
        End With
        x = .Value2
    End With
    With Sheets("race1")
        If .[a61] = vbNullString Then
            lRow = 61
        Else
            lRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 15 - .[c20]
        End If
        .Cells(lRow, 1).Resize(UBound(x, 1), UBound(x, 2)) = x
        .Columns(1).AutoFit
        .Activate
        ActiveWindow.ScrollColumn = 1
        ActiveWindow.ScrollRow = lRow
    End With
    
End Sub

Display More

The accompanying WORKSHEET 1 code

HTML

Private Sub Worksheet_Change(ByVal Target As Range)
If Not IsError(Application.Match([c2], [Times], 0)) Then
        Application.EnableEvents = 0
        check1
        Application.EnableEvents = 1
        
    End If
End Sub

The old problem is persisting when sheet 1 is live with the live time changing in cell C2, The check1 code will execute on time according to the schedule in 'race1' sheet the value in A20 will turn from 0 to 1 butthen when reverting from 1 to 0 after the first paste it quickly pastes again and I am left with this problem of 2 pastes rather than 1.

If I disable the live feed into 'sheet1' and manually enter time values that will match the schedule times on 'race1' sheet the check 1 code will fire once and work perfectly every time with a single paste.

KJ, I can only assume that if you have got this same code to paste once the problem is with the feed when it is live and changing. When I manually enter a time in C2 and it works fine and pastes once the 1 value in cell A20 on race1 sheet remains.Is the problem perhaps that when live and the time moves on past the schedule time again aftyer firing the macro, the change in cell A20 from 1 back down to zero is firing check one for a 2nd time.

before trigger time A20 =0 when hits trigger time changes to 1 and fires check 1
after trigger time A20 reverts back to 0 from 1 and fires for the 2nd time

Amazing how something that seemed so simple is proving to be so awkward!

I appreciate you have spent plenty of time on this already, If you think of anything new I would be most grateful, I will also be trying to see if I can find a similar problem on the net that was overcome.

Many Thanks

**KjBox** · May 1st 2019

A couple of changes you need to make.

Change the Update button code to

Code

Private Sub CommandButton2_Click()
    If Not IsError(Application.Match([a21], [Times], 0)) Then check1
End Sub

and the start of the check1 code should be

Code

Option Explicit
Dim NextTime As Double
Sub check1()
    Dim x, lRow As Long

Neither of those changes will stop check1 from running twice though!

For me making any change to Sheet1 will, if the time in C2 is an exact match to a time in race1 D1:L1, fire check1 just once (as does clicking the Update button).

If check1 runs twice when your Sheet1 gets automatically updated then I suspect that the fault lies in the code that does the automatic updating, I think it may be updating Sheet1 twice, or there is something in that code that checks the value of race1 A20. If so, then try commenting out the bit if code that checks A20.

Code executing Twice each time it's called...

Participate now!

Share

Users Viewing This Thread