Macro: Conditional row removal

Asked at 2017-01-11 19:51:43Z
  • 5 Subscribers
  • 114 Views
0

I was wondering if someone could help me with this. I am trying to create a macro to achieve the following:

I have the following excel table:

Letter  Number
A       15
A       2212
A       3741
B       251
B       7
B       14201
C       13503
C       97
C       113

I would like to build a macro which would go through the "letter column" and whenever there is the same letter, look at the "number column" beside it and delete the smaller values - keeping only the largest values.

I would like the end result to have only one entry for each letter and the corresponding value next to it as shown below:

Letter  Number
A       3741
B       14201
C       13503

Not sure how complicated of a macro this would be. Thanks in advance guys.


2 answers in total

0
VBA Pete Posted at 2017-01-11 20:24:35Z

If your letters are in column A and numbers are in column B, the following code should do the trick:

Sub FindMaxValue()

Dim CountLng As Long

'find range
CountLng = ActiveSheet.UsedRange.Rows.Count

'loop through range to find max
For x1 = CountLng To 2 Step -1
    For x2 = 2 To CountLng
        If Range("A" & x1).Value = Range("A" & x2).Value And x1 <> x2 Then
            If Range("B" & x1).Value >= Range("B" & x2).Value Then
                Rows(x2).EntireRow.Delete
                Exit for
            Else
                Rows(x1).EntireRow.Delete
                Exit For
            End If
        End If
    Next x2
Next x1

End Sub
0
user3598756 Posted at 2017-01-11 20:34:31Z

you could use Dictionary to hold each letter maximum value and then AutoFilter() to delete "lower" values letter rows:

Option Explicit

Sub min()
    Dim rng As Range, cell As Range
    Dim key As Variant

    Set rng = Range("B1", Cells(Rows.Count, "A").End(xlUp))
    With CreateObject("Scripting.Dictionary")
        For Each cell In rng.Resize(rng.Rows.Count - 1, 1).Offset(1)
            If .Exists(cell.value) Then
                If cell.Offset(, 1) > .item(cell.value) Then .item(cell.value) = cell.Offset(, 1).value
            Else
                .Add cell.value, cell.Offset(, 1).value
            End If
        Next
        Application.DisplayAlerts = False
        For Each key In .Keys
            rng.AutoFilter field:=1, Criteria1:=key
            rng.AutoFilter field:=2, Criteria1:="<" & .item(key)
            rng.Resize(rng.Rows.Count - 1, 1).Offset(1).SpecialCells(xlCellTypeVisible).Delete
            rng.AutoFilter
        Next
        Application.DisplayAlerts = True
    End With
End Sub

Answer this questsion