Sub pupils()
Dim sh As Worksheet, lr As Long, LastRow As Long, pupilsCount As Integer, pupilsRange As Range
Dim AppScrUpd
AppScrUpd = Application.ScreenUpdating
Application.ScreenUpdating = False

LastRow = 1
ThisWorkbook.Worksheets("Шаблон").Cells.Clear
For Each sh In ThisWorkbook.Worksheets
    If sh.Name <> "Шаблон" Then
        With sh
            lr = .Cells(.Rows.Count, 1).End(xlUp).Row
            Set pupilsRange = .Range("A2:B" & lr)
            pupilsCount = lr - 1
            With ThisWorkbook.Worksheets("Шаблон")
                .Cells(LastRow, 1) = sh.Name & " ----> " & pupilsCount & " учеников"
                .Cells(LastRow, 1).Interior.Color = 4697456
                With .Range(.Cells(LastRow, 1), .Cells(LastRow, 9))
                    .Merge
                    .HorizontalAlignment = xlCenter
                    .VerticalAlignment = xlCenter
                    .Font.Bold = True
                End With
                pupilsRange.Copy .Cells(LastRow + 1, 1)
                LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
                
            End With
        End With
    End If
Next sh
Application.ScreenUpdating = AppScrUpd
End Sub

Sub pupils()
Dim sh As Worksheet, lr As Long, LastRow As Long, pupilsCount As Integer, pupilsRange As Range
Dim AppScrUpd, j As Integer, arr(), shName, pupilsArray
j = 1
With ThisWorkbook
    For Each sh In .Worksheets
        If RegexExtract(sh.Name) Then
            If sh.Name <> "Шаблон" Then ReDim Preserve arr(1 To j): arr(j) = sh.Name: j = j + 1
        End If
    Next sh
End With

arr = sort_arr(arr)

AppScrUpd = Application.ScreenUpdating
Application.ScreenUpdating = False

LastRow = 1
ThisWorkbook.Worksheets("Шаблон").Cells.Clear
For Each shName In arr
    With ThisWorkbook.Worksheets(shName)
        lr = .Cells(.Rows.Count, 1).End(xlUp).Row
        pupilsArray = .Range("A2:B" & lr)
        pupilsArray = sort_pupil(pupilsArray)
        pupilsCount = lr - 1
        With ThisWorkbook.Worksheets("Шаблон")
            .Cells(LastRow, 1) = shName & " ----> " & pupilsCount & " учеников"
            .Cells(LastRow, 1).Interior.Color = 4697456
            With .Range(.Cells(LastRow, 1), .Cells(LastRow, 9))
                .Merge
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
                .Font.Bold = True
            End With
            .Cells(LastRow + 1, 1).Resize(UBound(pupilsArray, 1), UBound(pupilsArray, 2)) = pupilsArray
            LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
        End With
    End With
Next shName
Application.ScreenUpdating = AppScrUpd
End Sub
Private Function sort_arr(arr) As Variant
Dim i, j, tmp
    For i = LBound(arr) To UBound(arr)
        For j = i To UBound(arr)
            If arr(i) > arr(j) Then
                tmp = arr(j)
                arr(j) = arr(i)
                arr(i) = tmp
            End If
        Next j
    Next i
    sort_arr = arr
End Function
Private Function sort_pupil(arr) As Variant
Dim i, j, tmp
    For i = LBound(arr, 1) To UBound(arr, 1)
        For j = i To UBound(arr, 1)
            If arr(i, 2) > arr(j, 2) Then
                tmp = arr(j, 2)
                arr(j, 2) = arr(i, 2)
                arr(i, 2) = tmp
            End If
        Next j
    Next i
    sort_pupil = arr
End Function
Private Function RegexExtract(s As String) As Boolean
RegexExtract = False
With CreateObject("VBScript.Regexp")
    .Global = False: .MultiLine = False: .Pattern = "^\d[0-2]?[А-Жа-ж]$"
    If .test(s) Then RegexExtract = True: Exit Function
End With
End Function

If sh.Name <> "Шаблон" Then

If sh.Name <> "Шаблон" and sh.Name <> "имя1" and sh.Name <> "имя2" Then