Sub Макрос1()

Min = 9 ^ 9
For Each r In Range("F9:F19")
Range("C4") = r
  If r <> "" Then
    If Range("D4") <= Min Then Min = Range("D4")
  End If
Next
Range("H4") = Min

Range("C4") = WorksheetFunction.Index(Range("F9:F19"), WorksheetFunction.Match(Range("H4"), Range("G9:G19"), 0))

End Sub

Option Explicit

Sub main()
Dim lRowT As Long, lRowZ As Long
Dim q As Integer

    Const s_KEY_1 As String = "образ"
    Const s_KEY_2 As String = ","
    Const s_KEY_3 As String = "ТЕКСТ1-"
    Const s_DELIM As String = "+"
    ' - -
    Dim rngCell As Range
    ' - -
    With ThisWorkbook.Worksheets("Шкала-")
        On Error Resume Next
        Set rngCell = .Columns("J").Find(s_KEY_1, , xlValues, xlPart, xlByRows, xlPrevious, False, False, False)
        On Error GoTo 0
    End With 'ThisWorkbook.Worksheets("Лист4")
    
   
    
     
lRowT = Cells(Rows.Count, "E").End(xlUp).Row 'Определяем последнюю заполненную в столбце E
lRowZ = Cells(Rows.Count, "J").End(xlUp).Row 'Определяем последнюю заполненную в столбце J
 
lRowT = lRowT + 1
For q = lRowT To lRowZ
    If Trim(Cells(q, "J").Value) <> "" Then

    If rngCell Is Nothing Then MsgBox "Text not found!", vbExclamation: Exit Sub
    ' - -
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary"): dict.CompareMode = 1
    Dim sKey$, sKeyDelim$: sKeyDelim = Chr(1)
    ' - -
    Dim arrMain, i&, n&, sCumulative$
    ' - -
    arrMain = Split(rngCell.Value, s_KEY_1)
    sCumulative = ""

    ' - -
    With CreateObject("VBScript.RegExp")
        ' - -
        .Global = True: .IgnoreCase = True: .MultiLine = False
        ' - -
        n = UBound(arrMain, 1)
        For i = 1 To n
            ' - -
            .Pattern = "[^\d\wа-яё]+"
            ' - -
            arrMain(i) = .Replace(Split(arrMain(i), s_KEY_2)(0), "")
            ' - -
            .Pattern = "([^\d\s]+)(\d+)([^\d\s]+)"

            
            If .Test(arrMain(i)) Then
                ' - -
                sKey = Join(Array(.Replace(arrMain(i), "$1"), .Replace(arrMain(i), "$3")), sKeyDelim)
                ' - -
                If Not dict.Exists(sKey) Then
                    dict(sKey) = CLng(.Replace(arrMain(i), "$2"))
                Else
                    dict(sKey) = dict(sKey) + CLng(.Replace(arrMain(i), "$2"))
                End If 'Not dict.Exists(sKey)
                ' - -
            End If '.Test(arrMain(i))
            ' - -
        Next i
        ' - -
        n = dict.Count
        If n > 0 Then
            ' - -
            For i = 0 To n - 1
                ' - -
                sCumulative = sCumulative & s_DELIM & Replace$(dict.Keys()(i), sKeyDelim, dict.Items()(i))
                ' - -
            Next i
            ' - -
            sCumulative = s_KEY_3 & Right$(sCumulative, Len(sCumulative) - 1)
            ' - -
            With rngCell.Offset(2, 1)
                If InStr(1, .Value, sCumulative, vbTextCompare) = 0 Then _
                    .Value = Replace$(.Value, s_KEY_3, sCumulative, , , vbTextCompare)
            End With 'rngCell.Offset(2,1)
            ' - -
        End If 'dict.Count > 0
        ' - -
    End With 'CreateObject("VBScript.RegExp")

    End If
Next q
End Sub

lRowT = Cells(Rows.Count, "E").End(xlUp).Row 'Определяем последнюю заполненную в столбце E
lRowZ = Cells(Rows.Count, "J").End(xlUp).Row 'Определяем последнюю заполненную в столбце J
 
lRowT = lRowT + 1
For q = lRowT To lRowZ
    If Trim(Cells(q, "J").Value) <> "" Then

If Len(Replace(Range("I7:J4000"), " ", "")) = 0 Then MsgBox "Считайте меня пустой"