Sub фівфівфів()'
i = 2

Do While ThisWorkbook.Sheets("Input").Cells(i, 1) <> ""
         ThisWorkbook.Sheets(CStr(ThisWorkbook.Sheets("Input").Cells(i, 1))).Range(CStr(ThisWorkbook.Sheets("Input").Cells(i, 2))) = ThisWorkbook.Sheets("Input").Cells(i, 3)
          i = i + 1
Loop
End Sub

Private Sub EditList_Click()
'Dim lLastRow As Long
'   lLastRow = Cells(Rows.Count, 1).End(xlUp).Row
'   If IsNumeric(Cells(lLastRow, 1)) Then _
'Cells(lLastRow + 1, 1).Value = Cells(lLastRow, 1).Value + 1 Else _
'Oae eonie oi aeua aiaaaey? a inoaii?e ?yaie oaaeeo? oaeno
Cells(myRow, 2).Resize(, 10) = Array(CDate(Me.MyDate), exp.Value, inc.Value, _
  gru.Value, pgr.Value, cat.Value, pca.Value, , , Opys.Value)
Close #1
    filepath = ThisWorkbook.Path & "\"
    'Filename = Left(ThisWorkbook.Name, InStr(ThisWorkbook.Name, ".") - 1) & "_log.txt"
    Filename = "LOG_EXCEL.txt"
    Open filepath & Filename For Append As #1
 On Error Resume Next
    Print #1, Application.UserName; " " & Date & " " & Time & " "; ThisWorkbook.Name & " "; ActiveSheet.Name & "   " & ActiveCell.Address; ";", _
    ; Me.MyDate & ";" _
    ; exp.Value & ";" & inc.Value & ";", _
    gru.Value & ";" & pgr.Value & ";" & cat.Value & ";" & pca.Value & " ;" & " ;" & " ;" & Opys.Value
    On Error Resume Next
    Close #1
    original = Target.Text
'Cells(myRow, 6) = pgr.Value
'Opys.ValueClear
'Clear ia?aiao? ?enoeou aai? iiey ye? aea?ao aea ?iainu iai?ao??
EditMyForm.Hide
End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) 

Private Sub Worksheet_Change(ByVal Target As Range)

    ActiveSheet.Calculate
  Close #1
    filepath = ThisWorkbook.Path & "\"
    'Filename = Left(ThisWorkbook.Name, InStr(ThisWorkbook.Name, ".") - 1) & "_log.txt"
    Filename = "LOG_EXCEL.txt"
    Open filepath & Filename For Append As #1

  
    On Error Resume Next
    Print #1, Application.UserName; " " & Date & " " & Time & " "; ThisWorkbook.Name & " "; ActiveSheet.Name & "   " & " cell " & Target.Address & " : ;ñòàðå = ;[" & original & "], íîâå = ;[" & Target.Value & "]"
    On Error Resume Next
    Close #1
    original = Target.Text
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)

Dim shtLog As Worksheet
Dim cll As Variant
Dim lngNextRow As Long

Close #1
    Filepath = ThisWorkbook.Path & "\"
    'Filename = Left(ThisWorkbook.Name, InStr(ThisWorkbook.Name, ".") - 1) & "_log.txt"
    Filename = "LOG_EXCEL.txt"
    Open Filepath & Filename For Append As #1

    On Error Resume Next
    Print #1, Date & " " & Time & " " & ThisWorkbook.Name & " " & " cell " & Target.Address & " : ñòàðå = [" & original & "], íîâå = [" & Target.Value & "]"
    On Error Resume Next
    Close #1
    original = Target.Text
'Code by Sumit Bansal from http://trumpexcel.com
'On Error GoTo Handler
'If Target.Column = 3 And Target.Value <> "" Then
'Application.EnableEvents = False
''Target.Offset(0, -1) = Format(Now(), "dd.mm.yyyy")
'Target.Offset(0, -1) = Date
'Application.EnableEvents = True
'End If
'Handler:



ActiveSheet.Calculate




    Dim FilterCol As Integer
    Dim FilterRange As Range
    Dim CondtitionString As Variant
    Dim Condition1 As String, Condition2 As String
 
    If Intersect(Target, Range("ÔÑ")) Is Nothing Then Exit Sub
 
    On Error Resume Next
    Application.ScreenUpdating = False
     
    'îïðåäåëÿåì äèàïàçîí äàííûõ ñïèñêà
   Set FilterRange = Range("Table7")
     
    'ñ÷èòûâàåì óñëîâèÿ èç âñåõ èçìåíåííûõ ÿ÷ååê äèàïàçîíà óñëîâèé
    For Each cell In Target.Cells
        FilterCol = cell.Column - FilterRange.Columns(1).Column + 1
         
        If IsEmpty(cell) Then
            Target.Parent.Range(FilterRange.Address).AutoFilter field:=FilterCol
            ' çàëèøຠïóñò³ òà ô³ëüòðè
            Sheets("Çâ³ò").Range("A11:S11").EntireRow.Hidden = False
            On Error Resume Next
Sheets("Çâ³ò").Range("B6:B15000").SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = False

        Else
            If InStr(1, UCase(cell.Value), " ÀÁÎ ") > 0 Then
                LogicOperator = xlOr
                ConditionArray = Split(UCase(cell.Value), " ÀÁÎ ")
            Else
                If InStr(1, UCase(cell.Value), " ² ") > 0 Then
                    LogicOperator = xlAnd
                    ConditionArray = Split(UCase(cell.Value), " ² ")
                Else
                    ConditionArray = Array(cell.Text)
                End If
            End If
            'ôîðìèðóåì ïåðâîå óñëîâèå
            If Left(ConditionArray(0), 1) = "<" Or Left(ConditionArray(0), 1) = ">" Then
                Condition1 = ConditionArray(0)
            Else
                Condition1 = "=*" & ConditionArray(0) & "*"
            End If
            'ôîðìèðóåì âòîðîå óñëîâèå - åñëè îíî åñòü
            If UBound(ConditionArray) = 1 Then
                If Left(ConditionArray(1), 1) = "<" Or Left(ConditionArray(1), 1) = ">" Then
                    Condition2 = ConditionArray(1)
                Else
                    Condition2 = "=*" & ConditionArray(1) & "*"
                End If
            End If
            'âêëþ÷àåì ôèëüòðàöèþ
            If UBound(ConditionArray) = 0 Then
                Target.Parent.Range(FilterRange.Address).AutoFilter field:=FilterCol, Criteria1:=Condition1
                ' çàëèøຠïóñò³ òà ô³ëüòðè
            Sheets("Çâ³ò").Range("A11:S11").EntireRow.Hidden = False
            On Error Resume Next
Sheets("Çâ³ò").Range("B6:B15000").SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = False
            Else
                Target.Parent.Range(FilterRange.Address).AutoFilter field:=FilterCol, Criteria1:=Condition1, _
                    Operator:=LogicOperator, Criteria2:=Condition2
                    ' çàëèøຠïóñò³ òà ô³ëüòðè
            Sheets("Çâ³ò").Range("A11:S11").EntireRow.Hidden = False
            On Error Resume Next
    Sheets("Çâ³ò").Range("B6:B15000").SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = False
            End If
        End If
    Next cell
     
    Set FilterRange = Nothing
    Application.ScreenUpdating = True   
End Sub

Cells(myRow, 2).Resize(, 3) = Array(CDate(Me.MyDate), exp.Value, inc.Value, gru.Value, pgr.Value, cat.Value, pca.Value, Opys.Value)

Cells(myRow, 2) = CDate(Me.MyDate)
Cells(myRow, 3) = exp.Value
Cells(myRow, 4) = inc.Value

Cells(myRow, 2) = CDate(Me.MyDate), Cells(myRow, 3) = exp.Value, Cells(myRow, 4) = inc.Value

Sub StopTimerq()
    On Error Resume Next
    Application.OnTime RunWhenq, Procedure:=cRunWhatq, _
        Schedule:=False
Err.Clear: On Error GoTo 0: On Error GoTo -1
    MsgBox "Done"

Sub StopTimer()
    On Error Resume Next
    Application.OnTime RunWhen, Procedure:=cRunWhat, _
        Schedule:=False
Err.Clear: On Error GoTo 0: On Error GoTo -1
    MsgBox "Done"
End Sub

в Workbook
Private Sub Workbook_BeforeClose(Cancel As Boolean)
StopTimerq
StopTimer

End Sub

Option Explicit
Private Sub Workbook_Open()
     Application.Calculation = xlManual
    StartTimer
    StartTimerq
End Sub
'Private Sub Worksheet_Change(ByVal Target As Range)
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Application.Calculation = xlManual
ActiveSheet.Calculate
StartTimerq
End Sub
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, _
  ByVal Target As Excel.Range)
StartTimerq
End Sub
Private Sub Workbook_SheetCalculate(ByVal Sh As Object)
  StartTimerq
End Sub
Private Sub Workbook_Activate()
  StartTimerq
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
StopTimerq
StopTimer
End Sub
Private Sub Workbook_SheetDeactivate(ByVal Sh As Object)
    ThisWorkbook.Names.Add "prevsh__", Sh.Name
End Sub

Option Explicit
Public RunWhen As Double
Public Const cRunIntervalSeconds = 8 ' sec
Public Const cRunWhat = "TheSub"  ' the name of the procedure to run
Public RunWhenq As Double
Public Const cRunIntervalSecondsq = 20 ' sec
Public Const cRunWhatq = "TheSubq"  ' the name of the procedure to run
Sub StartTimer()
    RunWhen = Now + TimeSerial(0, 0, cRunIntervalSeconds)
    Application.OnTime EarliestTime:=RunWhen, Procedure:=cRunWhat, _
        Schedule:=True
End Sub
Sub TheSub()

If ThisWorkbook.Saved = False Then
    ThisWorkbook.Save
    StartTimer
    
    Else
    StartTimer
    End If

End Sub

Sub StopTimer()
    On Error Resume Next
    Application.OnTime EarliestTime:=RunWhen, Procedure:=cRunWhat, _
        Schedule:=False
End Sub
Sub StartTimerq()
    RunWhenq = Now + TimeSerial(0, 0, cRunIntervalSecondsq)
    Application.OnTime EarliestTime:=RunWhenq, Procedure:=cRunWhatq, _
        Schedule:=True
End Sub
Sub TheSubq()
With ActiveWorkbook
    .Save
    .Close
End With
End Sub
Sub StopTimerq()
    On Error Resume Next
    Application.OnTime EarliestTime:=RunWhenq, Procedure:=cRunWhatq, _
        Schedule:=False
End Sub