Sub ertert()
Dim i&
With Sheets("Источник").Range("B2").CurrentRegion
     For i = 1 To .Columns.Count Step 2
         With .Columns(i)
             .Offset(1).Resize(.SpecialCells(2).Count - 1, 2).Copy Sheets(.Cells(1).Value).Range("A3")
         End With
     Next
End With
End Sub

Sub tt()
     Application.ScreenUpdating = 0
     With Лист4
         c_ = .Cells(2, Columns.Count).End(xlToLeft).Column
         For i = 2 To c_ Step 2
             a_ = .Cells(2, i)
             r_ = .Cells(Rows.Count, i).End(xlUp).Row
             Sheets(a_).Rows("3:3333").Delete
             .Cells(3, i).Resize(r_ - 2, 2).Copy Sheets(a_).Range("B3")
             Sheets(a_).Range("A3").Resize(r_ - 2).FormulaR1C1 = "=SUM(R[-1]C,1)"
             Sheets(a_).Range("A3").Resize(r_ - 2) = Sheets(a_).Range("A3").Resize(r_ - 2).Value
             Sheets(a_).Range("C3").Resize(r_ - 2).Copy
             Sheets(a_).Range("A3").PasteSpecial Paste:=xlPasteFormats
             Application.CutCopyMode = False
         Next i
     End With
     Application.ScreenUpdating = 1
     MsgBox "Скопировано"
End Sub