Sub OneMoreProba()
    Dim wb As Workbook
    Set wb = ActiveWorkbook
    
    Dim arr As Variant
    arr = GetArr(wb)
    If IsEmpty(arr) Then Exit Sub
    
    Dim shRaschet As Worksheet
    On Error Resume Next
    Set shRaschet = Sheets("расчет")
    On Error GoTo 0
    If shRaschet Is Nothing Then Set shRaschet = Workbooks.Add(1).Sheets(1)
    
    With shRaschet.Cells(6, 1).Resize(UBound(arr, 1), UBound(arr, 2))
        .Value = arr
    End With
End Sub

Private Function GetArr(wb) As Variant
    ReDim arr(0 To 0)
    Dim sh As Worksheet
    For Each sh In wb.Worksheets
        If sh.Name <> "расчёт" Then
            JobSheet sh, arr
        End If
    Next
    If UBound(arr) > 0 Then
        Dim brr As Variant
        ReDim brr(1 To UBound(arr), 1 To UBound(arr(1)) + 1)
        Dim yy As Long
        Dim xx As Long
        For yy = 1 To UBound(brr, 1)
            For xx = 1 To UBound(brr, 2)
                brr(yy, xx) = arr(yy)(xx - 1)
            Next
        Next
        GetArr = brr
    End If
End Function

Private Sub JobSheet(sh As Worksheet, arr As Variant)
    With sh
        Dim yy As Long
        yy = .UsedRange.Row + .UsedRange.Rows.Count - 1
        If yy < 4 Then Exit Sub
        Dim brr As Variant
        brr = .Cells(1, 3).Resize(yy, 4)
    End With
    For yy = 4 To UBound(brr, 1)
        If brr(yy, 3) > 0 Or brr(yy, 4) > 0 Then
            ReDim Preserve arr(0 To UBound(arr) + 1)
            arr(UBound(arr)) = Array(brr(yy, 1), brr(yy, 2), brr(yy, 3), brr(yy, 4))
        End If
    Next
End Sub