View Full Version : Selecting the row with the highest value
eriden
09-20-2016, 09:36 AM
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
09-20-2016, 10:35 AM
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
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
09-21-2016, 12:49 AM
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
09-21-2016, 12:51 AM
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 :-)
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.