Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    Dim ShOut As Worksheet, shNm$, shInd&, row&
    shNm = Sh.Name
    Set ShOut = Me.Sheets("all_lists")
    If Len(shNm) = 2 Then                   'если длина имени 2 знака
        If Asc(shNm) = 115 Then             'Asc("s") если первый символ имени "s"
            Select Case Target.Column
            Case 2 To 4                     'изменяемые столбцы 2-4
                shInd = Right(shNm, 1) - 1  'получаем индекс листа из его имени
                With Target
                  row = .row + 19 * shInd - 1
                  ShOut.Cells(row, .Column).Resize(.Rows.Count, .Columns.Count).Value = Target.Value 'копируем измененные значения на лист "all_lists"
                End With
            End Select
        End If
    End If
End Sub

Sub ПереносДанных()
    Dim i&, shInd&, row&, shNm$
    Dim rngInp As Range, rngOut As Range, Sh As Worksheet, ShOut As Worksheet
    On Error Resume Next
    
    Set ShOut = ThisWorkbook.Sheets("all_lists")
    For Each Sh In ThisWorkbook.Sheets
        shNm = Sh.Name
        If Len(shNm) = 2 Then
            If Asc(shNm) = 115 Then
                shInd = Right(shNm, 1) - 1
                row = 2 + 19 * shInd
                Set rngInp = Range(Sh.Cells(3, 2), Sh.Cells(21, 4))
                Set rngOut = Range(ShOut.Cells(row, 2), ShOut.Cells(row + 18, 4))
                rngOut.Value = rngInp.Value
                rngOut.Select
            End If
        End If
    Next
End Sub

Sub СборДанных()
    Dim shNames(), arrInp(), arrOut()
    Dim Sh As Worksheet, ShOut As Worksheet
    Dim r1&, r2&, lr&, shInd&, shNm
    
    shNames = Array("s1", "s2", "s3", "s4") 'имена всех листов с данными
    ReDim arrOut(1 To 5000, 1 To 3)
    
    With ThisWorkbook
      For Each shNm In shNames
          With .Sheets(shNm)
            lr = .UsedRange.Rows.Count + 1
            arrInp = Range(.Cells(3, 2), .Cells(lr, 4))
          End With
          For r1 = 1 To UBound(arrInp)
              If arrInp(r1, 3) Then
                  r2 = r2 + 1
                  arrOut(r2, 1) = arrInp(r1, 1)
                  arrOut(r2, 2) = arrInp(r1, 2)
                  arrOut(r2, 3) = arrInp(r1, 3)
              End If
          Next
      Next
      Set ShOut = .Sheets("all_lists")
    End With
    
    ShOut.Range("B:D").ClearContents
    With ShOut.Range("B2:D2").Resize(r2) 'вывод данных на лист "all_lists" со второй строки
        .Value = arrOut
        .Sort Key1:=.Cells(1)
    End With
End Sub

If arrInp(r1, 3) <> 0 Then

If Len(arrInp(r1, 3))> 0 Then

If VarType(arrInp(r1, 3)) = 5 Then