Sub test()
    Dim sht As Worksheet, lrow&
    For Each sht In Worksheets
        If sht.Name <> "Sheet_name" Then
            With Worksheets("Sheet_name")
                sht.Rows(1).Copy .Rows(1)
                lrow = .Range("a" & .Rows.Count).End(xlUp).Row
                sht.UsedRange.Offset(1, 0).Copy .Range("a" & lrow + 1)
            End With
        End If
    Next sht
End Sub

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
    Dim iSource1 As Range, iSource2 As Range, iCell As Range
    
    Set iSource1 = Range("A1") '[A1]
    Set iSource2 = Intersect(Target, iSource1)
   
    If iSource2 Is Nothing Then Exit Sub
    If iCollection.Count = 0 Then iTimer = Now 'Time
    
    On Error Resume Next
    For Each iCell In iSource2
        If Not IsEmpty(iCell) Then
           iCollection.Add "", iCell.Address
        Else
           iCollection.Remove iCell.Address
        End If
    Next

    If iCollection.Count = iSource1.Count Then
       If DateDiff("s", iTimer, Now) > 1 Then
          MsgBox "Rucinoi vvod zapreshion!"
       End If
       iTimer = 0: Set iCollection = Nothing
    End If
End Sub

Sub        
      n = 1
        For c = 1 To 3
            'Change Selection
            Cells(1, c).Select
            For r = 1 To Range(Selection, Selection.End(xlDown)).Count
                Cells(n, 4) = Cells(r, c)
                n = n + 1
            Next r
        Next c
End Sub