Sub TblMerge()
Dim ws As Worksheet
Dim arr()
Dim dic As Object, iKey, lRow&
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
Set dic = CreateObject("Scripting.Dictionary")
With dic
  For Each ws In ThisWorkbook.Worksheets
    If ws.Name = "НОВЫЙ" Then ws.Delete
    If ws.Name <> "СВОД" Then
      With ws
        arr = .Range("B3:D" & .Cells(.Rows.Count, "B").End(xlUp).Row).Value
      End With
      .Item(.Count) = arr
    End If
    Erase arr
  Next
End With
Worksheets.Add.Name = "НОВЫЙ"
With Worksheets("НОВЫЙ")
  Worksheets("Лист1").Range("B2:D2").Copy .Range("B2")
  For Each iKey In dic.Keys
    lRow = .Cells(.Rows.Count, "B").End(xlUp).Row + 1
    .Cells(lRow, 2).Resize(UBound(dic(iKey), 1), 3) = dic(iKey)
  Next
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub