A worksheet is unexpectedly activated

I have a macro assigned to a button that runs perfectly on the data in the active sheet and in other sheets as well using Excel 2010. However, when I try to run it using Excel 2013 or Excel 2016, a different sheet is unexpectedly activated so the macro generates an error. There is nothing in the code that activates this other sheet and, to be safe, the macro disables events, even though there is nothing in the event code that even references to this other sheet. I have tried assigning the active sheet name to a variable at the beginning of the macro and the using that variable to activate the sheet even though it is already the active sheet, but the other sheet is still activated. I was wondering if anyone else has experienced this problem. I was hoping to get some feedback on what could possibly cause this to happen. As I already mentioned, it runs without errors using Excel 2010. My suspicion is that there is a glitch in the 2013 and 2016 versions of Excel. I haven't posted the code because it is quite long and part of a large project that calculates the final results of a cross country meet. If anyone has any suggestions or would like the code to be posted, I can certainly do that. Many thanks in advance.

Also posted at: https://www.mrexcel.com/board/forums...10/post-thread

And stepping through doesn't allow you to notice the sheet activation change?

I have tried that with no success.

So while stepping through you are not able to see when this other sheet becomes active...

Is there a way to setup a demo file with minimum code to see if it still occurs...Perhaps workbook has become corrupt...

The code works perfectly using Excel 2010 so the workbook is not corrupt.

Of course...you mentioned that...apologies...very strange indeed...

No apologies necessary. It is strange and that's why I think there is a glitch in 2013 and 2016.

Perhaps breaking code down in smaller modules and test in 2013 & 2016...

Thank you for the suggestion. Unfortunately, I can't do that because some lines of code are inter-connected so it would be hard to do. What is very strange is that I open Excel 2010, open the file, click all the buttons and everything works. I close 2010 and repeat those steps using Excel 2013 and I get the errors.

I experienced 2010 vs 2013 glitches with listrows.add code before...So anything is possible...
Is however workarounds but one can only ascertain with file or code snippets unfortunately...

This the code. I should mention that I also have a different macro which generates the same problem.

Sub RaceResults()
    With Application
        .ScreenUpdating = False
        .Cursor = xlWait
        .EnableEvents = False
    End With
    Sheets("FinalStandings").Unprotect Password:="iwbi48crci"
    Sheets("RegionQualifiers").Unprotect Password:="iwbi48crci"
    ActiveSheet.Unprotect Password:="iwbi48crci"
    Dim bottomC As Long
    'Deletes blank rows.
    With Range("A3:E123")
        .AutoFilter 1, ""
        .AutoFilter 2, ""
        .AutoFilter 3, ""
    End With
    With ActiveSheet
        .AutoFilter.Range.Offset(3).EntireRow.Delete
        .Range("A3").AutoFilter
    End With
    'Inserts "?" if student name is missing.
    Dim bottomE As Long
    bottomE = Range("e" & Rows.Count).End(xlUp).Row
    On Error Resume Next
    Range("A4:A" & bottomE).SpecialCells(xlCellTypeBlanks) = "?"
    On Error GoTo 0
    'Looks for incorrect or missing school codes and asks for correction.
    Dim x As Long
    For x = 4 To bottomE
        If Range("B" & x) = "" Or Range("C" & x) = "" Then
            Cells(x, "A").Activate
            Application.Goto ActiveCell.EntireRow, True
            Do
                schcode = InputBox("The school code for the runner in Position " & Range("D" & x) & " is either missing or incorrect. Enter the correct school code.", "Correct School Code")
                If schcode <> "" Then
                    If Range("B" & x) = "" Or Range("C" & x) = "" Then Range("B" & x) = schcode
                    Exit Do
                ElseIf schcode = "" Then
                    MsgBox ("You must enter a valid school code in cell B" & x & " for the runner in Position " & Range("D" & x)) & "."
                    Else: Exit Do
                End If
            Loop
        End If
    Next x
    'Sorts according to School.
    Cells(3, 1).Sort Key1:=Columns(3), Order1:=xlAscending, Orientation:=xlTopToBottom, Header:=xlYes
    'Numbers runners.
    Range("f3") = 1
    With Range("F4")
        .FormulaR1C1 = "=IF(((AND((RC[-5]=""""),(RC[-4]=""""),(RC[-3]="""")))),"""",IF((AND(RC[-5]<>"""",RC[-4]=R[-1]C[-4])),R[-1]C+1,IF(RC[-5]="""",R[-1]C,1)))"
        .AutoFill Destination:=Range("F4:F123"), Type:=xlFillDefault
    End With
    'Filters top 3 runners in each school.
    Range("A3:F3").AutoFilter Field:=6, Criteria1:="<4"
    bottomE = Range("E" & Rows.Count).End(xlUp).Row
    'Subtotals top 3 runners.
    Range("A3" & ":E" & bottomE + 1).Subtotal GroupBy:=3, Function:=xlSum, TotalList:=Array(5), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
    Range("F4").FillDown
    bottomE = Range("E" & Rows.Count).End(xlUp).Row
    'Deletes Grand Total line.
    Rows(bottomE).Delete
    If Range("F5") = "" Then Range("F5").FormulaR1C1 = _
        "=IF(((AND((RC[-5]=""""),(RC[-4]=""""),(RC[-3]="""")))),"""",IF((AND(RC[-5]<>"""",RC[-4]=R[-1]C[-4])),R[-1]C+1,IF(RC[-5]="""",R[-1]C,1)))"
    Range("F5:F" & bottomE).FillDown
    'Selects Teams with at least 3 runners and puts them in order of finish
    Dim r As Long, bottomF As Long, bottomH As Long, bottomJ As Long, FirstCell As Range, LastCell As Range
    bottomF = Range("F" & Rows.Count).End(xlUp).Row
    bottomH = Range("H" & Rows.Count).End(xlUp).Row
    bottomJ = Range("J" & Rows.Count).End(xlUp).Row
    'Formats headers for Team data range.
    Columns("H:H").ColumnWidth = 8
    Columns("I:I").ColumnWidth = 40
    Columns("K:K").ColumnWidth = 12
    Range("H3").Value = "Order"
    Range("I3").Value = "School"
    Range("K3").Value = "Team Points"
    With Range("H3:K3")
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .Interior.ColorIndex = 44
        .Borders(xlEdgeBottom).LineStyle = xlDouble
    End With
    With Range("H4:H185,J4:J185")
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
     End With
    'Copies Teams to Team data range.
    Dim dic As Object, school As Range, srcRng As Range
    Set dic = CreateObject("Scripting.Dictionary")
    Set srcRng = Range("C4:C" & bottomF).SpecialCells(xlCellTypeVisible)
    For Each school In srcRng
        If school Like "*Total" And school.Offset(, 2) > 0 And school.Offset(, 3) > 2 Then
            x = school.Offset(, 2).Value
            dic.Add school, x
        End If
    Next school
    Dim shName As Range, col As String
    With Sheets("FinalStandings")
        Set shName = .Rows(1).Find(ActiveSheet.Name, LookIn:=xlValues, lookat:=xlWhole)
        col = Replace(Cells(1, shName.Column).Address(False, False), "1", "")
        .Range(col & 2, .Range(col & .Rows.Count).End(xlUp)).Value = .Range(col & 2, .Range(col & .Rows.Count).End(xlUp)).Value
    End With
    Range("A3").AutoFilter
    Range("I4").Resize(dic.Count).Value = Application.Transpose(dic.keys)
    Range("K4").Resize(dic.Count).Value = Application.Transpose(dic.items)
    Columns("J").Delete Shift:=xlToLeft
    With Range("H:H,K:K")
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
    End With
    'Removes the word "Total" from school name.
    Range("I4", Range("I" & Rows.Count).End(xlUp)).Replace "Total", "", xlPart
    'Aligns Column I to left.
    With Range("I:I")
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlBottom
    End With
    'Formats cell K3 - "Position First Runner".
    With Range("K3")
        .Value = "Position First Runner"
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = True
        .Interior.ColorIndex = 44
        .Borders(xlEdgeBottom).LineStyle = xlDouble
    End With
    'Breaks ties among teams.
    Cells(4, 10).Sort Key1:=Columns(10), Order1:=xlDescending, Orientation:=xlTopToBottom, Header:=xlYes
    'Numbers team order.
    With Range("H4")
        .Value = "1"
        .AutoFill Destination:=Range("H4").Resize(Range("I" & Rows.Count).End(xlUp).Row - 3), Type:=xlFillSeries
    End With
    'Enters Position of team runners.
    Dim team As Range, fnd As Range
    For Each team In Range("I4", Range("I" & Rows.Count).End(xlUp))
        Set fnd = Range("C:C").Find(Trim(team), LookIn:=xlValues, lookat:=xlWhole)
        If Not fnd Is Nothing Then
            team.Offset(, 2) = fnd.Offset(, 1)
        End If
    Next team
    'Deletes formulae and leaves values by Column in FinalStandings sheet
    Dim Column As String, bottomColumn As Long
    With ActiveSheet
        If .Name = "13 Yr Boys" Then Column = "C"
        If .Name = "12 Yr Boys" Then Column = "D"
        If .Name = "11 Yr Boys" Then Column = "E"
        If .Name = "10 Yr Boys" Then Column = "F"
        If .Name = "9 Yr Boys" Then Column = "G"
        If .Name = "8 Yr Boys" Then Column = "H"
        If .Name = "13 Yr Girls" Then Column = "I"
        If .Name = "12 Yr Girls" Then Column = "J"
        If .Name = "11 Yr Girls" Then Column = "K"
        If .Name = "10 Yr Girls" Then Column = "L"
        If .Name = "9 Yr Girls" Then Column = "M"
        If .Name = "8 Yr Girls" Then Column = "N"
    End With
    bottomColumn = Sheets("FinalStandings").Range(Column & Rows.Count).End(xlUp).Row
    Sheets("FinalStandings").Range(Column & 2, Column & bottomColumn).Value = Sheets("FinalStandings").Range(Column & 2, Column & bottomColumn).Value
    Columns("F:F").Delete
    With Range("F3")
        .Interior.ColorIndex = xlNone
        .Borders(xlEdgeBottom).LineStyle = xlNone
    End With
    Cells(1, 6).ColumnWidth = 2
    Cells(1, 8).ColumnWidth = 30
    'Aligns Column I to center.
    With Range("I:I")
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
    End With
    Dim bottomD As Long
    bottomD = Range("d" & Rows.Count).End(xlUp).Row
    bottomE = Range("e" & Rows.Count).End(xlUp).Row
    Range("A3:E" & bottomE).Select
    With ActiveSheet.Sort
        .SortFields.Clear
        .SortFields.Add Key:=Range("D4:D" & bottomD), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange Range("A3:E" & bottomE)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    'Copies top 22 runners into RegionQualifiers
    Range("A4:C25").Copy
    Sheets("RegionQualifiers").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial (xlPasteValues)
    'Finds team runners outside of top 22 runners.
    bottomC = Range("C" & Rows.Count).End(xlUp).Row
    bottomH = Range("H" & Rows.Count).End(xlUp).Row
    Dim FirstTeam As String, SecondTeam As String
    FirstTeam = Trim(Range("H4"))
    SecondTeam = Trim(Range("H5"))
    Dim Counter As Long: Counter = 0
    For r = 4 To bottomC
        Set FirstCell = Range("A" & r)
        Set LastCell = Range("D" & r)
        If Range("A" & r).Offset(0, 2) = FirstTeam Then Counter = Counter + 1
        If Range("A" & r).Offset(0, 2) = FirstTeam And LastCell > 22 And Counter <= 3 _
        Then Range(FirstCell, LastCell.Offset(0, -1)).Copy _
        Destination:=Sheets("RegionQualifiers").Range("A1").End(xlDown).Offset(1, 0)
    Next r
    Counter = 0
    For r = 4 To bottomC
        Set FirstCell = Range("A" & r)
        Set LastCell = Range("D" & r)
        If Range("A" & r).Offset(0, 2) = SecondTeam Then Counter = Counter + 1
        If Range("A" & r).Offset(0, 2) = SecondTeam And LastCell > 22 And Counter <= 3 _
        Then Range(FirstCell, LastCell.Offset(0, -1)).Copy _
        Destination:=Sheets("RegionQualifiers").Range("A1").End(xlDown).Offset(1, 0)
    Next r
    'Copies Race Name into column D in RegionQualifiers.
    Dim myDest As Range
    Sheets("RegionQualifiers").Range("D" & Rows.Count).End(xlUp)(2).Value = Range("A2").Value
    With Sheets("RegionQualifiers")
        Set myDest = .Range("A" & Rows.Count).End(xlUp).Offset(, 3)
        With .Range("D" & Rows.Count).End(xlUp)
            .AutoFill Sheets("RegionQualifiers").Range(.Cells, myDest), xlFillCopy
        End With
    End With
    bottomJ = Range("J" & Rows.Count).End(xlUp).Row
    bottomI = Range("I" & Rows.Count).End(xlUp).Row
    Range("H4:J" & bottomJ).Select
    With ActiveSheet.Sort
        .SortFields.Clear
        .SortFields.Add Key:=Range("I4:I" & bottomI), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
        .SortFields.Add Key:=Range("J4:J" & bottomJ), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange Range("H3:J" & bottomJ)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    With ActiveSheet
        .Shapes.Range(Array("Rounded Rectangle 4")).Visible = False
        .Shapes.Range(Array("Rounded Rectangle 1")).Visible = False
        .Shapes.Range(Array("Rounded Rectangle 3")).Visible = True
        .Cells.Locked = True
    End With
    bottomB = Range("B" & Rows.Count).End(xlUp).Row + 1
    Rows(bottomB & ":" & bottomC).Delete
    Sheets("FinalStandings").Protect Password:="iwbi48crci"
    Sheets("RegionQualifiers").Protect Password:="iwbi48crci"
    ActiveSheet.Protect Password:="iwbi48crci"
    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
        .Cursor = xlDefault
        .EnableEvents = True
    End With
    Range("A1").Select
End Sub

Wow Mumps1...That's a lot of procedure for 1 module...I suggest breaking it down into smaller modules...Also, that code can be simplified a lot...
Are you not able to supply a file and explain requirements...Even just smaller segment requirements which will allow for more simplified code to be supplied...
Somewhere in all of that there is a reason for this issue...

I'm sorry but the macros generate many different errors one of which makes Excel hang and I have to use the Task Manager to close it. I think it would be as frustrating for you as it is for me. Also, it contains a large amount of student data which I cannot make public and would take too long to de-sensitize. If you think that the code can be simplified, could I impose on you to perhaps do that for me and I will give it a try. Maybe that will fix the problem.

Without some kind of sample file, all supplied code will be untested which defeats the purpose...Write a snippet to change student names and confidential data and supply a sample...This is only alternative...Can't see any other way I'm afraid...

OR

Break your code into smaller modules...Referencing specific sheets with WITH statements...And Not With Activesheet...This will ensure code executes for those specific sheets only...

I will see if I can de-sensitize the data. I have to use Activesheet because there are 12 sheets that have a button to run the same macro.

Remove the buttons and make use of a modeless userform or add a button to your ribbon...
Anyway...Making use of With Sheet Specified statements will surely solve your problem...Good Luck...

I have managed to de-desensitize the data. I would respectfully suggest that you save the file before you click any button. The School Name and Student Code are entered manually on site after each race after which the "Calculate Results" button is clicked. This is done for each race. Then the "Finalize Meet Results" button on the "FinalStandings" sheet is clicked. You will notice that there is a "School" sheet with school names and codes. There are 12 sheets, one for each event, a "FinalStandings" sheet and a "RegionalQualifiers" sheet that are populated automatically. The "FinalStandings" sheet and "Labels" sheet have buttons which are self-explanatory. The "Finalize Meet Results" button on the "FinalStandings" sheet and "Create School Copy of File" button on the "Labels" sheet save files to the Desktop. If you have access to Excel 2010, I would suggest that you try it out with that so you can see how it works without errors.

K Cool, a bit late now, but will have a look in the morrow...

Much appreciated.

I notice now why your code always pops up asking for a entry...It activates the "Final Standings" Sheet when buttons are pressed...Does not happen when code is stepped through though...

Also, if you have time...explain your ranking table to the right of data and why some have more entries than others...If the exact requirement can be explained I am so so certain it can be simplified...
Also...Just to understand...Each sheet is selected individually and then button pressed...

I tried stepping through and the problem still exists. The macro looks for blank cells in columns B and C. It asks for an entry even though there are no blank cells in the active sheet because it should be referencing the active sheet, but since the active sheet has changed, it generates the request. I guess you don't have access to Excel 2010?

I think you misread...I also get your issue...Am on 2019 now...will run on 2013 & 2016 tomorrow...

I notice now why your code always pops up asking for a entry...It activates the "Final Standings" Sheet when buttons are pressed...Does not happen when code is stepped through though...

My apologies. Look forward to tomorrow.

Hi Mumps1, please see post 20 regarding RHS Ranking Table...

Hi Mumps1

Have a look at this simplification...This works on all the "*Yr*" Sheets...
I have not incorporated any code that has to do with "Final Standings Sheet" & have removed the protection code...You can add later
Also try and avoid any "Activate" or "On Error" snippets unless really needed...
I suggest adding a snippet as soon as I know what must be done on that sheet with the extracted data...

Also...I advise not having User input Info during Code runs...
Rather do a check and inform if anything needs still to be populated....See red snippet in code below...

Sub J3v16()
Dim Data, Arr, Temp, Dict As Object, Trip As Boolean
Dim i As Long, ii As Long, x As Long, lr As Long, sr As Long
Set Dict = CreateObject("Scripting.Dictionary")
With Range("A3:E" & Cells(Rows.Count, 5).End(xlUp).Row).Columns(4)
    .Value = Evaluate("=IF(ROW(" & .Address & "),IF((" & .Offset(, -3).Address & "="""")*(" & .Offset(, -2).Address & "="""")*(" & .Offset(, -1).Address & "=""""),""""," & .Address & "))")
End With
sr = Cells(Rows.Count, 4).End(xlUp).Row: lr = Cells(Rows.Count, 5).End(xlUp).Row + 1
Rows(sr + 1 & ":" & lr).Delete
With Range("A3:E" & Cells(Rows.Count, 5).End(xlUp).Row)
    If Application.CountBlank(.Cells) > 1 Then
        .SpecialCells(xlCellTypeBlanks) = "?"
        MsgBox "PLEASE POPULATE ALL CELLS WITH QUESTION MARKS", vbInformation, ""
        Exit Sub
    End If
    Arr = .Value
    .Sort .Columns(3), xlAscending, , .Columns(5), xlDescending, , , xlYes
    Data = .Value:  ReDim Temp(1 To UBound(Data), 1 To 4)
    For i = 2 To UBound(Data)
        If Application.CountIf(.Columns(3), Data(i, 3)) >= 3 Then
            If Not Dict.exists(Data(i, 3)) Then
                Trip = False: x = 0
                Dict.Add Data(i, 3), ""
                ii = ii + 1: x = x + 1
                Temp(ii, 1) = Data(i, 3)
                Temp(ii, 2) = Data(i, 5)
                Temp(ii, 3) = Data(i, 4)
            ElseIf Trip = False Then
                x = x + 1: Temp(ii, 2) = Temp(ii, 2) + Data(i, 5)
                If x = 3 Then Trip = True
            End If
        End If
    Next i
    .Value = Arr
End With
With Range("G4").Resize(, 4)
    .Value = Array("Order", "School", "Team Points", "Position First Runner")
    .Interior.ColorIndex = 44
    .Borders(xlEdgeBottom).LineStyle = xlDouble
    With .Offset(1, 1).Resize(ii, 4)
        .Value = Temp
        .Sort .Columns(2), xlDescending, , , , , , xlNo
        .Offset(, -1).Columns(1).Value = Evaluate("Row(1:" & .Rows.Count & ")")
    End With
    With .Resize(ii + 1)
        .HorizontalAlignment = xlCenter
       .Columns.AutoFit
    End With
End With
End Sub

I suggest also making use of a Modeless Userform to Run the code for each Active Sheet...

@zzzeddy
Thank you for the suggestion. I tried something similar to that and unfortunately, the problem persisted.

@sintek
First of all, thank you so much for helping out with this task. You should know that I am a retired school Principal and started coding on this task as a volunteer more than 10 years ago, before I retired. It took a couple of years of trial and error to get to where it is today. Unfortunately, although Excel is said to be backward compatible, I guess that is not always true, hence the problems. Regarding the ranking table to the right of data: A school must have at least 3 runners in a race to qualify as a team so if a school has only one or two runners, that school will not appear in the Team list to the right. The team points are based on the top 3 runners in each school. Ties are broken based on the position of the first runner in each of the tied teams. Yes, each sheet is selected individually and then the button is pressed. The reason I have the user input data while the code is running is because if a school code is not entered or an invalid school code is entered and the results are calculated, it throughs off both the team results and running totals. The best time to correct this is on site because all the runners and their coaches are present and can be consulted as to the identification of the missing runner. After the meet, this would be very hard to do. If you need any more information, please let me know. Please give me a little time to try and incorporate your suggestions into my coding and I will get back to you.

Thanks for clarification Mumps1...
Code produces the exact same results as yours...so I assume it does work...
With regards to the User Input...If the User is running the system on site, then he is there anyway for missed entries to be filled in again prior to re-running code...Or am I missing something...Anyway...have a look at sample file I attached and we'll take it from there...

PS I added blue snippets in code above to have data left in same order as it started...

With the added blue snippets I get "Application define or Object define error" on this line"

 .Value = Evaluate("=IF(ROW(" & .Address & "),IF((" & .Offset(, -3).Address & "="""")*(" & .Offset(, -2).Address & "="""")*(" & .Offset(, -1).Address & "=""""),""""," & .Address & "))")

Not with my sample file attached above...All sheets run perfectly...

Right you are!!! I should also let you know that RoryA at MrExcel has offered a suggestion that works.
https://www.mrexcel.com/board/thread...vated.1219213/
However, I like your code because it is so much more efficient than mine so I am going to take some time and try to incorporate it with what already works. Thank you so much once again for all your time. It is very much appreciated.

Glad to have helped...The other code that does Whatever for the Total Sheet...can also be simplified...but hey baby steps...If it "ain't broke"...

So true.