طلب كود vba

[sof17]

لديا عمود فيها المجموعات وعمود فيه الصنف اريد جلب اكبر قيمة في المجموعات مع اكبر قيم تقابلها في هذه المجموعة 

test.xlsx

[محمد هشام.]

وعليكم السلام ورحمة الله تعالى وبركاته 

جرب هل هدا ما تقصده 

Option Explicit
Sub FindMaxClass()
    Dim tmp As Double
    Dim i&, kay&, n&, lastRow
    Dim WS As Worksheet: Set WS = Sheets("Sheet1")
    lastRow = WS.Cells(WS.Rows.Count, 2).End(xlUp).Row
    tmp = Application.WorksheetFunction.Max(WS.Range("B2:B" & lastRow))
    n = 0
    For i = 2 To lastRow
        If WS.Cells(i, 2).value = tmp Then
            If WS.Cells(i, 1).value > n Then
                n = WS.Cells(i, 1).value
            End If
        End If
    Next i
    
   kay = n
   WS.Range("E1").Resize(1, 2).value = Array(kay, tmp)
End Sub

لتنفيد الكود مباشرة عند التغيير في أحد الأعمدة 

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim WS As Worksheet
    Set WS = Me
    If Not Intersect(Target, WS.Range("A:B")) Is Nothing Then
        If Target.Row > 1 Then
            Dim i As Long, kay As Long, lastRow As Long
            Dim a As Variant, tmp As Double
            lastRow = WS.Cells(WS.Rows.Count, 2).End(xlUp).Row
            
            a = WS.Range("A2:B" & lastRow).value
            tmp = Application.WorksheetFunction.Max(Application.Index(a, 0, 2))
            kay = 0
            For i = LBound(a, 1) To UBound(a, 1)
                If a(i, 2) = tmp Then
                    If a(i, 1) > kay Then
                        kay = a(i, 1)
                    End If
                End If
            Next i
         WS.Range("E1").Resize(1, 2).value = Array(kay, tmp)
        End If
    End If
End Sub

 

test1.xlsb

تم تعديل أكتوبر 16, 2024 بواسطه محمد هشام.

[sof17]

شكرا استاذ هشام