Sub BuildPlan()

Range("A77:U3000").Select
Selection.Delete


Const startCell = "A5"
Const stCell = "A73"

Dim ws As Worksheet, sv As Worksheet
Dim cell As Range, tbl As Range, shift&

Set sv = ThisWorkbook.Worksheets("Svod")
Set cell = sv.Range(stCell)
cell.CurrentRegion.Offset(cell.Row - cell.CurrentRegion.Row).Clear

For Each ws In ThisWorkbook.Worksheets
If Not ws Is sv Then
Set tbl = ws.Range(startCell).CurrentRegion
shift = ws.Range(startCell).Row - tbl.Row
If tbl.Rows.Count - shift > 0 Then
tbl.Offset(shift).Resize(tbl.Rows.Count - shift).Copy cell
Set cell = cell.Offset(tbl.Rows.Count - shift)
End If
End If
Next
End Sub

Sub BuildPlan()

Range("A100:S5000").Select
   Selection.ClearContents
   
    Const startCell = "A100"
    
    Dim ws As Worksheet, sv As Worksheet
    Dim cell As Range, tbl As Range, shift&
    
    Set sv = ThisWorkbook.Worksheets("Svod")
    Set cell = sv.Range(startCell)
    cell.CurrentRegion.Offset(cell.Row - cell.CurrentRegion.Row).Clear
    
    For Each ws In ThisWorkbook.Worksheets
        If Not ws Is sv Then
            Set tbl = ws.Range(startCell).CurrentRegion
            shift = ws.Range(startCell).Row - tbl.Row
            If tbl.Rows.Count - shift > 0 Then
                tbl.Offset(shift).Resize(tbl.Rows.Count - shift).Copy cell
                Set cell = cell.Offset(tbl.Rows.Count - shift)
            End If
        End If
    Next
End Sub

Sub HideCollumn()
Columns(5).EntireColumn.Hidden = False
End Sub

Sub Êíîïêà1_Ùåë÷îê()
Dim aa As Range, bb As Range, cc As Range, a&, b&, c&
Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet
'----------

    With ThisWorkbook
        .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = "881"
        .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = "878"
        .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = "876"
    End With
    
Set sh1 = Sheets("881"): Set sh2 = Sheets("878"): Set sh3 = Sheets("876"): b = 17

With Sheets(1)
  a = .Cells(.Rows.Count, "B").End(xlUp).Row
  If .Cells(a, 2).MergeCells Then a = a + .Cells(a, 2).MergeArea.Rows.Count
  Do
    c = b
    Do While Not .Cells(b, 2).MergeCells
      b = b + 1
      If b > a Then Exit Do
    Loop
    
    If b > a Then Exit Do
    If InStr(.Cells(b, 2), "881") Then
      If aa Is Nothing Then
        Set aa = .Range(.Cells(c, 2), .Cells(b + .Cells(b, 2).MergeArea.Rows.Count - 1, "X"))
      Else: Set aa = Union(aa, .Range(.Cells(c, 2), .Cells(b + .Cells(b, 2).MergeArea.Rows.Count - 1, "X")))
      End If
      
    Else
    
    If b > a Then Exit Do
    If InStr(.Cells(b, 2), "878") Then
      If bb Is Nothing Then
        Set bb = .Range(.Cells(c, 2), .Cells(b + .Cells(b, 2).MergeArea.Rows.Count - 1, "X"))
      Else: Set bb = Union(bb, .Range(.Cells(c, 2), .Cells(b + .Cells(b, 2).MergeArea.Rows.Count - 1, "X")))
      End If
    End If
    End If
    
    b = b + .Cells(b, 2).MergeArea.Rows.Count
  Loop Until b > a
End With

If Not aa Is Nothing Then aa.Copy sh1.[A1]
If Not bb Is Nothing Then bb.Copy sh2.[A1]
If Not cc Is Nothing Then cc.Copy sh3.[A1]

End Sub