Sub ConsolidatedList()
    On Error GoTo err1
    Application.ScreenUpdating = False
    With ActiveWorkbook.Worksheets("Èòîãè")
        .Cells(5, 1).Resize(.UsedRange.Rows.Count, 2).ClearContents
        Set DistCell = .Cells(1, 2).End(xlDown)
        For Each MonthSH In ActiveWorkbook.Worksheets
            If MonthSH.Name <> .Name Then
                r = 4
                If UCase(MonthSH.Range("b5").End(xlDown).Value) = "ИТОГО" Then r = 5
                MonthSH.Range("b5").Resize(MonthSH.Range("b5").End(xlDown).Row - r, 1).Copy
                DistCell.Offset(1, 0).PasteSpecial _
                    Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=False
              Set DistCell = DistCell.Offset(1, 0).End(xlDown)
            End If
        Next
        .Cells(4, 1).Resize(.Cells(4, 2).End(xlDown).Row, 2).RemoveDuplicates Columns:=Array(1, 2), _
                Header:=xlYes
    End With
err1:
    Application.ScreenUpdating = True
End Sub