Private Sub Worksheet_Change(ByVal Target As Range)
  'для всех ячеек столбцов 'G' и 'H'
  If Intersect(Union(Columns("G"), Columns("H")), Target) Is Nothing Or Target.Count <> 1 Then Exit Sub
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  Dim fndList As Variant
  Dim rplcList As Variant
  Dim x As Long, Tmp
  Tmp = Target
  fndList = Array("FHH", "FGA", "+")
  'в строке ниже 'Target.Column =...' должно быть равно НОМЕРУ столбца, для которого 'проверено...', во втором будет 'зачищено...'
  rplcList = IIf(Target.Column = 8, Array("FST", "FPT", "проверено"), Array("FST", "FPT", "зачищено"))
  For x = LBound(fndList) To UBound(fndList)
        Target.Replace What:=fndList(x), Replacement:=rplcList(x), _
          LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
          SearchFormat:=False, ReplaceFormat:=False
  Next x
  If Tmp <> Target Then Target = Target & " - " & Date
  Application.EnableEvents = True
  Application.ScreenUpdating = True
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
  If Intersect(Union(Columns("A"), Columns("B")), Target) Is Nothing Or Target.Count <> 1 Then Exit Sub
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  Dim fndList As Variant
  Dim rplcList As Variant
  Dim x As Long, Tmp
  Tmp = Target
  fndList = Array("FHH", "FGA", "+")
  rplcList = IIf(Target.Column = 1, Array("FST", "FPT", "проверено"), Array("FST", "FPT", "зачищено"))
  For x = LBound(fndList) To UBound(fndList)
        Target.Replace What:=fndList(x), Replacement:=rplcList(x), _
          LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
          SearchFormat:=False, ReplaceFormat:=False
  Next x
  If Tmp <> Target Then Target = Target & " - " & Date
  Application.EnableEvents = True
  Application.ScreenUpdating = True
End Sub

Sub Several()
Dim arr()
Dim rngGrafik As Range
Dim iCl As Range
Dim iDt As Date
Dim iTxt$
On Error Resume Next
Application.ScreenUpdating = False
Application.EnableEvents = False
With Worksheets("Лист1")  'лист с Графиком и таблицей
  arr = .Range("G4:I" & .Cells(.Rows.Count, "I").End(xlUp).Row).Value 'адрес таблицы с обозначениями
  Set rngGrafik = .Range("B4:E7") 'адрес диапазона-графика
  For Each iCl In rngGrafik.SpecialCells(xlCellTypeFormulas).Cells
    If iCl = "неск." Then
      iDt = CDate(rngGrafik(1, iCl.Column - 1).Value) ' -1 - смещение по столбцам (диапазон-график начинается со столбца 'B')
      For I = LBound(arr, 1) To UBound(arr, 1)
        If iDt = CDate(arr(I, 1)) Or iDt = CDate(arr(I, 2)) Then
          iTxt = IIf(iTxt = "", arr(I, 3), iTxt & vbCrLf & arr(I, 3))
        End If
      Next
      With iCl
        .ClearComments
        .AddComment
        .Comment.Text (iTxt)
        .Comment.Shape.TextFrame.AutoSize = True
      End With
    End If
  Next
End With
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

Option Base 1

Sub Pathfinder()
Const Bg& = 50, Ed& = 2000, Sp& = 50  'первое значение шага, последнее значение шага, шаг
Dim arr()
Dim arrItog()
Dim dic As Object
Dim dicItog As Object
Dim I&, J&, N&, ii&
Dim iKey, iTmp, iVr
Dim tm As Single

tm = Timer
On Error Resume Next
Application.ScreenUpdating = False
With Worksheets("Условия")
  arr = .Range("A2:A" & .Cells(.Rows.Count, "A").End(xlUp).Row).Value
End With

Set dic = CreateObject("Scripting.Dictionary")
Set dicItog = CreateObject("Scripting.Dictionary")

ReDim arrItog(1 To UBound(arr, 1), 1 To Int(Ed / Sp))
ReDim iTmp(1 To 1)

For N = Bg To Ed Step Sp
  For I = LBound(arr, 1) To UBound(arr, 1): iVr = dic(arr(I, 1)): Next
  For I = LBound(arr, 1) To UBound(arr, 1)
    iKey = arr(I, 1)
    If dic.Exists(iKey + N) Then
      J = 1
      For ii = I To UBound(arr, 1)
        If dic.Exists(iKey + N * J) Then
          dic.Remove (iKey + N * J)
          J = J + 1
        End If
      Next
      J = J - 1
      iTmp(UBound(iTmp)) = iKey & " [" & J & "]"
      ReDim Preserve iTmp(UBound(iTmp) + 1)
    End If
  Next
  dicItog.Add N, iTmp
  ReDim iTmp(1 To 1)
Next
N = 0: J = 0
For Each iKey In dicItog.Keys
  J = J + 1
  iTmp = dicItog(iKey)
  For I = LBound(iTmp) To UBound(iTmp)
    N = N + 1
    arrItog(N, J) = iTmp(I)
  Next
  N = 0
Next
With Worksheets("МАКРОС")
  .UsedRange.Value = Empty
  .Range("A1").Resize(, dicItog.Count) = dicItog.Keys
  .Range("A2").Resize(UBound(arrItog, 1), UBound(arrItog, 2)) = arrItog
  .Activate
End With
Application.ScreenUpdating = True
MsgBox "Done!" & vbCrLf & Round((Timer - tm) * 1000, 0) & " мсек.", vbOKOnly
End Sub

Sub Remove_From_dicCopy()
Dim arr()
Dim dic As Object
Dim dicCopy As Object
Dim iTmp, iKey

Set dic = CreateObject("Scripting.Dictionary")
Set dicCopy = CreateObject("Scripting.Dictionary")

With Worksheets("Лист1")
  arr = .Range("A2:A" & .Cells(.Rows.Count, "A").End(xlUp).Row).Value
  'заполняем основной словарь Ключами, без значений
  For Each iKey In arr
    iTmp = dic(iKey)
  Next
  'копия основного словаря
  Set dicCopy = dic
  'удаляем из КОПИИ словаря ключи, кратные 3 (не важно какие)
  For Each iKey In dicCopy.Keys
    If iKey Mod 3 = 0 Then dicCopy.Remove (iKey)
  Next
  
  .Range("D2").Resize(dic.Count) = Application.Transpose(dic.Keys)
  .Range("E2").Resize(dicCopy.Count) = Application.Transpose(dicCopy.Keys)

End With
End Sub