Sub Кнопка1_Щелчок()
   Dim sh1 As Worksheet
    Dim sh2 As Worksheet
    Set sh1 = Sheets("Ввод")
       
    Dim colName As String
    Dim arr As Variant
    Dim xx As Long
    With sh1
        For xx = 2 To .UsedRange.Column + .UsedRange.Columns.Count - 1
            On Error Resume Next
            Set sh2 = Sheets(.Cells(1, xx).Value)
            On Error GoTo 0
            If Not sh2 Is Nothing Then
                With .Cells(2, xx).Resize(10)
                    arr = .Value
                    .ClearContents
                End With
                colName = .Cells(1, 6).Value & " " & .Cells(1, 7).Value
                CheckEmpty arr
                CopyRange arr, sh2, colName
               
                Set sh2 = Nothing
            End If
        Next
         
        Dim dt As Date
        On Error Resume Next
        dt = DateValue("01 " & colName)
        On Error GoTo 0
        If dt > 0 Then
            dt = DateSerial(Year(dt), Month(dt) + 1, 1)
            .Cells(1, 6).Value = Format(dt, "MMMM")
            .Cells(1, 7).Value = Year(dt)
        End If
         
    End With
End Sub
   
Private Sub CheckEmpty(arr As Variant)
    Dim yy As Long
    For yy = 1 To UBound(arr, 1)
        If Not IsEmpty(arr(yy, 1)) Then Exit Sub
    Next
    For yy = 1 To UBound(arr, 1)
        arr(yy, 1) = "=RC[-2]"
    Next
End Sub
 
   
Private Sub CopyRange(arr As Variant, sh As Worksheet, colName As String)
    Dim xx As Long
    With sh
        On Error Resume Next
        xx = WorksheetFunction.Match(colName, .Rows(1), 0)
        On Error GoTo 0
        If xx = 0 Then
            xx = .Cells(1, .Columns.Count).End(xlToLeft).Column + 2
            .Cells(1, xx).Value = colName
        End If
        .Cells(2, xx).Resize(UBound(arr, 1), UBound(arr, 2)) = arr
    End With
    
End Sub