Sub sbor()
    With Sheets("клиенты")
        ark = .Cells(2, 2).Resize(.Cells(.Rows.Count, 2).End(3).Row - 1)
    End With
    c0_ = 4
    r0_ = 6
    r00_ = 3
    nc_ = WorksheetFunction.Count(Rows(3))
    nr_ = Cells(Rows.Count, 2).End(3).Row - r0_ + 2
    ar = Cells(r0_, c0_).Resize(nr_, nc_)
    ar0 = Cells(r00_, c0_).Resize(1, nc_)
    Set slov1 = CreateObject("Scripting.Dictionary")
    Set slov2 = CreateObject("Scripting.Dictionary")
    With slov1
        For i = 1 To UBound(ark)
            aaa = .Item(ark(i, 1))
            aaa = slov2.Item(ark(i, 1))
        Next i
        For i = 1 To nr_ Step 2
            For j = 1 To nc_
                If ar0(1, j) < 1 Then
                    If Not IsEmpty(ar(i, j)) Then
                        If .exists(ar(i, j)) Then
                            .Item(ar(i, j)) = .Item(ar(i, j)) + ar(i + 1, j)
                            slov2.Item(ar(i, j)) = slov2.Item(ar(i, j)) + 1
                        Else
                            t_ = t_ & "; " & ar(i, j)
                        End If
                    End If
                End If
            Next j
        Next i
        n_ = .Count
    End With
    With ActiveSheet
        .Cells(50, 3).Resize(.Cells(.Rows.Count, 1).End(3).Row, 3).ClearContents
        .Cells(48, 3).ClearContents
        .Cells(50, 3).Resize(n_) = Application.Transpose(slov1.Keys)
        .Cells(50, 4).Resize(n_) = Application.Transpose(slov2.items)
        .Cells(50, 5).Resize(n_) = Application.Transpose(slov1.items)
        If t_ <> "" Then
            .Cells(48, 3) = Mid(t_, 3)
        End If
    End With
End Sub

.Cells(50, 4).Resize(n_) = Application.Transpose(slov1.items)