Selecting the row with the highest value

[eriden]

Hi,

I really need some help creating a macro. I have the following table:



RefID
ColumnB
ColumnC
Value


100
abc
def
100


101
ghi
jkl
200


101
mno
pqr
500


102
stu
vuw
100


102
aaa
ccc
1000


102
abb
ddd
500




I want to go through the table, and for every duplicate in the first column (RefID), I want to copy the entire row with the highest value. So for refID 101 I want to copy the row with value 500, the one for refID 102 the row with value 1000. Also, sometimes you have multiple refID's with the same value - then I just want to pick one at random (the rows will be identical, so it doesn't matter).

In the end I want to have to following table in another worksheet:



RefID
ColumnB
ColumnC
Value


100
abc
def
100


101
mno
pqr
500


102
aaa
ccc
1000



Is anyone able to help me with this? Would be highly appreciated. :-)

[Paul_Hossler]

Maybe something like this





Option Explicit

Sub Macro1()
Dim ws As Worksheet
Dim rDataHeaders As Range, rData As Range
Dim iRow As Long

Application.ScreenUpdating = False

ActiveSheet.Copy After:=ActiveSheet

Set ws = ActiveSheet
Set rDataHeaders = ws.Cells(1, 1).CurrentRegion
Set rData = rDataHeaders.Cells(2, 1).Resize(rDataHeaders.Rows.Count - 1, rDataHeaders.Columns.Count)

With ws.Sort
.SortFields.Clear
.SortFields.Add Key:=rData.Columns(1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SortFields.Add Key:=rData.Columns(4), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
.SetRange rDataHeaders
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

With rDataHeaders
For iRow = .Rows.Count To 3 Step -1
If .Cells(iRow, 1).Value = .Cells(iRow - 1, 1).Value Then
.Rows(iRow).EntireRow.Delete
End If
Next iRow
End With

Application.ScreenUpdating = True
End Sub

[SamT]

Option Explicit

Sub VBAX_SamT()
Dim Cel As Range
Dim DestSht As Worksheet
Dim SrcSht As Worksheet

Set DestSht = Sheets("Sheet2") '<<<<<
Set SrcSht = Sheets("Sheet1") '<<<<<

Set Cel = SrcSht.Range("A2") '<<<<

Do

If Cel = Cel.Offset(1) Then
Do: Set Cel = Cel.Offset(1)
If Cel.Row > SrcSht.UsedRange.Rows.Count Then Exit Sub
Loop While Cel.Value = Cel.Offset(1).Value
End If

Cel.Resize(, 4).Copy DestSht.Cells(Rows.Count, "A").End(xlUp).Offset(1)

Set Cel = Cel.Offset(1)
Loop

End Sub

[eriden]

Maybe something like this





Option Explicit

Sub Macro1()
Dim ws As Worksheet
Dim rDataHeaders As Range, rData As Range
Dim iRow As Long

Application.ScreenUpdating = False

ActiveSheet.Copy After:=ActiveSheet

Set ws = ActiveSheet
Set rDataHeaders = ws.Cells(1, 1).CurrentRegion
Set rData = rDataHeaders.Cells(2, 1).Resize(rDataHeaders.Rows.Count - 1, rDataHeaders.Columns.Count)

With ws.Sort
.SortFields.Clear
.SortFields.Add Key:=rData.Columns(1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SortFields.Add Key:=rData.Columns(4), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
.SetRange rDataHeaders
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

With rDataHeaders
For iRow = .Rows.Count To 3 Step -1
If .Cells(iRow, 1).Value = .Cells(iRow - 1, 1).Value Then
.Rows(iRow).EntireRow.Delete
End If
Next iRow
End With

Application.ScreenUpdating = True
End Sub



Worked like a charm! Thank you so much :-)

[eriden]

Option Explicit

Sub VBAX_SamT()
Dim Cel As Range
Dim DestSht As Worksheet
Dim SrcSht As Worksheet

Set DestSht = Sheets("Sheet2") '<<<<<
Set SrcSht = Sheets("Sheet1") '<<<<<

Set Cel = SrcSht.Range("A2") '<<<<

Do

If Cel = Cel.Offset(1) Then
Do: Set Cel = Cel.Offset(1)
If Cel.Row > SrcSht.UsedRange.Rows.Count Then Exit Sub
Loop While Cel.Value = Cel.Offset(1).Value
End If

Cel.Resize(, 4).Copy DestSht.Cells(Rows.Count, "A").End(xlUp).Offset(1)

Set Cel = Cel.Offset(1)
Loop

End Sub



This doesn't seem to account for the values in column 4? But thank you :-)