Sub Main()
Dim ws As Worksheet, x As Worksheet, i As Long, j As Long, a(), b(), list()
Application.ScreenUpdating = False: Application.Calculation = xlManual
With Sheets("Svodnaya")
i = .Cells(Rows.Count, 2).End(xlUp).Row
a = .Range("A3:B" & i).Value
b = .Range("D3:P" & i).Value
list = .Range("C3:C" & i).Value
End With
For Each ws In Sheets
If Val(ws.Name) <> 0 Then ws.Rows("3:" & Rows.Count).ClearContents
Next
For i = 1 To UBound(a, 1)
On Error Resume Next
Set x = Sheets(CStr(list(i, 1)))
If Err <> 0 Then
Sheets(CStr(list(1, 1))).Copy After:=Sheets(Sheets.Count)
Set x = ActiveSheet: x.Name = CStr(list(i, 1))
x.Rows("3:" & Rows.Count).ClearContents
x.PageSetup.CenterHeader = x.Name
On Error GoTo 0
End If
j = x.Cells(Rows.Count, 2).End(xlUp).Row + 1
If j = 2 Then j = 3
x.Range(x.Cells(j, "A"), x.Cells(j, "B")).Value = Application.Index(a, i, 0)
x.Range(x.Cells(j, "C"), x.Cells(j, "O")).Value = Application.Index(b, i, 0)
Next
Sheets("Svodnaya").Activate
Application.ScreenUpdating = True: Application.Calculation = xlAutomatic
End Sub