Страницы: 1
RSS
Найти максимальное значение (B:B) среди повторяющихся значений (A:A) VBA, Данную задачу нужно решить с помощью массивов VBA
 
Добрый день!
Недавно на форуме было простенькая задача, которую можно решить формулой массивов =макс(если(то то то). Стало интересно, как её реализовать с помощью средств ВБА, перебрал много вариантов, все ок, а вот с помощью массивов не могу решить, помогите оптимизировать код.
Условие:
коля2
вова43
вова2
коля11
петя543
вова1
петя23
Должно получиться Коля - 11, Вова - 43, Петя - 543
Помогите нубу.
Код
Sub test()
   Dim n() As Variant
   Dim c As Long
   Dim lLastRow As Long, lasCou As Long
   Dim SUP As String
   Dim PUP As Long
   
   
    lLastRow = Cells(Rows.Count, 1).End(xlUp).Row
    lasCou = Cells(1, Columns.Count).End(xlToLeft).Column
    
    ReDim Preserve n(lLastRow - 1, lasCou - 1)
        For i = 0 To lLastRow - 1
            n(i, 0) = Range("A" & i + 1)
            n(i, 1) = Range("B" & i + 1)
    Next i
    
J = 0
For i = 0 To 6
    SUP = n(i, 0) '= SUP 'коля
    PUP = n(i, 1) '= PUP '2
    
    For s = 0 To 6
        If n(s, 0) = SUP And n(s, 1) > PUP Then
        PUP = n(s, 1)
    End If
    Next s
    J = J + 1
    Cells(J, 4).Value = SUP
    Cells(J, 5).Value = PUP
   
Next i

End Sub
 
Код
Sub MAXIFS()
Dim arr(), I&
arr = Range("A1:B" & Cells(Rows.Count, 1).End(xlUp).Row).Value
On Error Resume Next
With CreateObject("Scripting.Dictionary")
    For I = 1 To UBound(arr)
        .Add arr(I, 1), arr(I, 2)
        If Err <> 0 Then
            If arr(I, 2) > .Item(arr(I, 1)) Then .Item(arr(I, 1)) = arr(I, 2)
            Err.Clear
        End If
    Next
    Range("C1").Resize(.Count, 2) = Application.Transpose(Array(.Keys, .Items))
End With
End Sub
Согласие есть продукт при полном непротивлении сторон
 
Sanja, без словаря это можно как-нибудь сделать?
 
Можно, только Словарь то чем не угодил?
Согласие есть продукт при полном непротивлении сторон
 
Не нравится словарь? Получите коллекцию ))
Код
Sub Macro1()
Dim i As Long, j As Long, Arr(), Uniq As New Collection
Dim Imya, ArrOut, iMax As Long, LastRow As Long
    LastRow = Cells(Rows.Count, 1).End(xlUp).Row
    Arr = Range(Cells(1, 1), Cells(LastRow, 2)).Value
    For i = 1 To UBound(Arr)
        On Error Resume Next
        Uniq.Add Arr(i, 1), CStr(Arr(i, 1))
    Next
    ReDim ArrOut(1 To Uniq.Count, 1 To 2)
    For Each Imya In Uniq
        j = j + 1
        ArrOut(j, 1) = Imya
        For i = 1 To UBound(Arr)
            If Arr(i, 1) = Imya Then
                If Arr(i, 2) > iMax Then
                    iMax = Arr(i, 2)
                    ArrOut(j, 2) = iMax
                End If
            End If
        Next
        iMax = 0
    Next
    Range("D1").Resize(j, 2).Value = ArrOut
End Sub

 
Цитата
OblivionR написал:
без словаря это можно как-нибудь сделать?
Можно и без массивов и циклов :)
Код
Sub Макрос3()
  Columns("A").Copy Range("D1")
  Columns("D").RemoveDuplicates Columns:=1, Header:=xlNo
  With Range("E1:E" & Cells(Rows.Count, "D").End(xlUp).Row)
    .Cells(1).FormulaArray = Replace("=MAX(IF(R1C1:R@C1=RC[-1],R1C2:R@C2))" _
      , "@", Cells(Rows.Count, 1).End(xlUp).Row)
    .FillDown
    .Value = .Value
  End With
End Sub
 
Всем спасибо, вопрос решен.
Страницы: 1
Наверх