Sub sdf()
    Dim Dic As Object
    Dim sh As Worksheet
    Dim r As Range, w As Range, c As Range
    Dim arr() As Variant, arr1 As Variant
    Dim i, j, k, l, m, n, o
    
    Set Dic = CreateObject("scripting.dictionary")
    For Each w In Sheets("Criteria").Cells.SpecialCells(xlCellTypeConstants, 1).Areas
        With w.Offset(-1, -1).Resize(1, 1)
            n = Abs(Mid(.Value, InStrRev(.Value, "(")))
        End With
        For Each c In w.Offset(, -1)
            Dic(n & "_" & c) = c.Offset(, 1)
        Next
    Next
    With Sheets("Result(было)")
        m = .UsedRange.Columns.Count
        n = .Columns(1).SpecialCells(xlCellTypeConstants, 23).Areas.Count
        Set r = .[A1].CurrentRegion
        ReDim arr(1 To n * m, 1 To 6)
        For i = 1 To n
            For j = 1 To m
                o = (i - 1) * m + j
                If Not IsEmpty(r(1, j)) Then
                    For k = 1 To 3
                       arr(o, k) = r(k, j)
                    Next
                    l = 0
                    For k = 4 To r.Rows.Count
                        l = l + Dic(arr(o, 2) & "_" & r(k, j))
                    Next
                    If l Then arr(o, 5) = l
                    s = ""
                    On Error Resume Next
                    With r.Columns(j)
                        arr1 = Intersect(.Offset(3), .Cells).SpecialCells(xlCellTypeConstants, 23)
                        If IsArray(arr1) Then
                            s = Join(Application.Transpose(arr1), "_")
                        ElseIf Not IsEmpty(arr1) Then
                            s = arr1
                        End If
                        Erase arr1
                    End With
                    arr(o, 6) = s
                End If
            Next
            Set r = r.End(xlDown).End(xlDown).CurrentRegion
            n = n + 1
        Next
    End With
    Application.ScreenUpdating = 0: Application.EnableEvents = 0
    With Sheets("+++++").UsedRange
        Intersect(.Offset(1), .Cells).Clear
        .Cells(4, 1).Resize(o, 6).Value = arr
    End With
    Application.ScreenUpdating = 1: Application.EnableEvents = 1
    Set Dic = Nothing
    Set r = Nothing
    Set w = Nothing
    Set c = Nothing
    Erase arr
End Sub