Помогите разобраться с таблицей.

[AleksandrH]

Screamr
Вариант 1:

Sub Extract_Unique()
    Dim avArr, li As Long, ii As Long, jj As Long, isNew As Boolean
    ReDim avArr(1 To Rows.Count, 1 To 2)
    With New Collection
        On Error Resume Next
        For ii = 2 To Cells(Rows.Count, 1).End(xlUp).Row
            isNew = True
            .Add ii, Cells(ii, 1) & ":" & Cells(ii, 4)
            If Err = 0 Then
                For jj = 1 To li
                    If avArr(jj, 1) = Cells(ii, 1) And Len(avArr(jj, 2)) < Len(Cells(ii, 4)) Then
                        isNew = False
                        Exit For
                    End If
                Next
                If isNew Then
                    li = li + 1: avArr(li, 1) = Cells(ii, 1): avArr(li, 2) = Cells(ii, 4)
                Else
                    avArr(jj, 1) = Cells(ii, 1): avArr(jj, 2) = Cells(ii, 4)
                End If
                
            End If
        Next
    End With
    If li Then
        [F2:G2].Resize(li).Value = avArr
    End If
End Sub

форму sumif для ячеек Н2:Нх пропишете?

[Screamr]

нет, если можете напишите
спасибо большое

[AleksandrH]

Варіант2

Sub Extract_Unique()
    Dim avArr, li As Long, ii As Long, jj As Long, isNew As Boolean
    ReDim avArr(1 To Rows.Count, 1 To 3)
    With New Collection
        On Error Resume Next
        For ii = 2 To Cells(Rows.Count, 1).End(xlUp).Row
            isNew = True
            .Add ii, Cells(ii, 1) & ":" & Cells(ii, 4)
            If Err = 0 Then
                For jj = 1 To li
                    If avArr(jj, 1) = Cells(ii, 1) And Len(avArr(jj, 2)) < Len(Cells(ii, 4)) Then
                        isNew = False
                        Exit For
                    End If
                Next
                If isNew Then
                    li = li + 1: avArr(li, 1) = Cells(ii, 1): avArr(li, 2) = Cells(ii, 4): avArr(li, 3) = Int(Cells(ii, 3))
                Else
                    avArr(jj, 1) = Cells(ii, 1): avArr(jj, 2) = Cells(ii, 4): avArr(jj, 3) = avArr(jj, 3) + Int(Cells(ii, 3))
                End If
                
            End If
        Next
    End With
    If li Then
        [F2:H2].Resize(li).Value = avArr
    End If
End Sub

Ребята, если захотят, еще вариантов могут подкинуть