VBA – Merge CEIP report data to one sheet

I created a macro to merge CEIP report data to one sheet. It eases a following analysis of the data. Centre on Emission Inventories and Projections (CEIP) gathers reports and data about pollution year by year from European countries. Reports and data are available here.

Final result is not formatted but it contains freeze panels.

Macro works with an active workbook. It was tested on Czech and Danish 2018 Submission.

You can copy and paste or download it.

'Procedure sort sheets with 4 digit names like 1990, 2015 and etc.
'Then, it creates a sheet named "Merge" with a header. The header is a copy of header from CEIP report.
'And finally, it copies data from sheets year by year.

Sub MainMergeSheets()

    Dim shColl As New Collection
    Dim yearNum
    Dim NUM_COPIED_ROWS As Single
    Dim min4DigitName As Integer
    'Number of rows copied from every sheets
    NUM_COPIED_ROWS = 128
    
    'Speed up macro by disable screen updating
    Application.ScreenUpdating = False
    
    'Sort sheets with 4 digit name
    SortSheetsTabName
    'First sheet with 4 digit name is the lowest after SortSheetsTabName procedure
    min4DigitName = First4DigitSheetName
    'Create the Merge sheet and add header
    CreateMergeSheet
    
    For Each sh In ActiveWorkbook.Sheets
        If (sh.name Like "####") Then
            shColl.Add sh, sh.name
        End If
    Next sh
    
    'Merge specific cells from other sheet to "Merge" sheets
    For Each sh In shColl
        yearNum = sh.name - min4DigitName + 1
        sh.Range("A14:AL141").Copy
        Sheets("Merge").Range("B" & 5 + ((yearNum - 1) * NUM_COPIED_ROWS) & ":AL" & 2 + (yearNum * NUM_COPIED_ROWS)).PasteSpecial Paste:=xlPasteValues
        Application.CutCopyMode = False
        With Sheets("Merge").Range("A" & 5 + ((yearNum - 1) * NUM_COPIED_ROWS) & ":A" & 4 + (yearNum * NUM_COPIED_ROWS))
            .NumberFormat = "General"
            .Value = sh.name
        End With
    Next sh
    
    'Application.ScreenUpdating turn on
    Application.ScreenUpdating = True
    
    'Select first row at the bottom to show last result
    Sheets("Merge").Range("A" & (shColl.Count * NUM_COPIED_ROWS) + 5).Select
End Sub
Private Sub SortSheetsTabName()
    Dim iSheets%, i%, j%
    iSheets = Sheets.Count
    For i = 1 To iSheets - 1
        For j = i + 1 To iSheets
            If Sheets(j).name < Sheets(i).name Then
                If Sheets(i).name Like "####" Then
                    Sheets(j).Move Before:=Sheets(i)
                End If
            End If
        Next j
    Next i
End Sub
Private Function First4DigitSheetName() As Integer
    Dim i%
    For i = 1 To Sheets.Count
        If Sheets(i).name Like "####" Then
            First4DigitSheetName = CInt(Sheets(i).name)
            Exit Function
        End If
    Next i
End Function
Private Sub CreateMergeSheet()
    Dim i%
    For i = 1 To Sheets.Count
        If Sheets(i).name = "Merge" Then
            Application.DisplayAlerts = False
            Sheets(i).Delete
            Application.DisplayAlerts = True
            Exit For
        End If
    Next i
    Sheets.Add(Before:=Sheets(1)).name = "Merge"
    Sheets(CStr(First4DigitSheetName)).Range("A10:AL13").Copy
    Sheets("Merge").Range("B1").PasteSpecial Paste:=xlPasteValues
    Sheets("Merge").Range("B5").Activate
    ActiveWindow.FreezePanes = True
End Sub