Just Keep 1 Row for each Account

[justdream]

Dears,

I've 24 Hours Data for each Account, I need Macro to copy
only one row for each Account based on Maximum cost in Column "F"
and paste in next Excel tab

Below is Draft copy of my working Data
Thanks for your support

[SamT]

What is the name of the "next tab," and what does it look like?

[justdream]

What is the name of the "next tab," and what does it look like?

We could give it any name "Max cost Data"
and it should contains same Row Main header as in Draft "sheet1"
plus Macro output which is
Complete copy of Row Data for each account where its Hourly Cost reach maximum value

[justdream]

Output should be like this

[mdmackillop]

Sub GetData()
Dim col As New Collection
Dim AC As String, TCH As String
Dim cel As Range
Dim i, x As Single, y As Single
AC = Range(Cells(2, 4), Cells(Rows.Count, 4).End(xlUp)).Address
TCH = Range(AC).Offset(, 2).Address
On Error Resume Next
For Each cel In Range(AC)
col.Add cel, cel
Next
On Error GoTo 0
For Each i In col
y = Evaluate("=MAX(IF(" & AC & "=" & """" & i & """" & ",TCH))")
x = Evaluate("=SUMPRODUCT(--(" & AC & " = " & """" & i & """" & "),--(TCH = " & y & "),ROW(" & AC & "))")
Cells(x, 1).Resize(, 12).Copy Sheets(2).Cells(Rows.Count, 1).End(xlUp)(2)
Next
End Sub

[justdream]

Thanks mdmackillop
it gives me Run time error "13"
Type mismatch

and highlight this row code:


y = Evaluate("=MAX(IF(" & AC & "=" & """" & i & """" & ",TCH))")

[mdmackillop]

I just noticed that. See revised posting

[SamT]

Dr Mack, your XL-Dennis link is dead. :(

[justdream]

I'm afraid it's still giving same error

[mdmackillop]

Try this version


Sub GetData()
Dim col As New Collection
Dim AC As String, TCH As String
Dim cel As Range
Dim i, x As Single, y As Single
AC = Range(Cells(2, 4), Cells(Rows.Count, 4).End(xlUp)).Address
TCH = Range(AC).Offset(, 2).Address
On Error Resume Next
For Each cel In Range(AC)
col.Add cel, cel
Next
On Error GoTo 0
For Each i In col
y = Evaluate("=MAX(IF(" & AC & "=" & """" & i & """" & "," & TCH & "))")
x = Evaluate("=SUMPRODUCT(--(" & AC & " = " & """" & i & """" & "),--(" & TCH & " = " & y & "),ROW(" & AC & "))")
Cells(x, 1).Resize(, 12).Copy Sheets(2).Cells(Rows.Count, 1).End(xlUp)(2)
Next
End Sub

[justdream]

Thanks a lot for giving me of your time..
This time we have Run time Error "9"
Subscript out of range

for last line on code


Cells(x, 1).Resize(, 12).Copy Sheets(2).Cells(Rows.Count, 1).End(xlUp)(2)

[mdmackillop]

Do you have 2 sheets in your workbook?

[justdream]

No just one "sheet1"
I've attached it in my original post

Many Thanks

[justdream]

I got it, it's working well Thanks

Just please could tell me where in your codes you have pointed
for columns D & F
so I could change in case of different Data arrangement

[justdream]

Sorry, Dear
I've tried Macro code with large amount of Data
but it didn't give me Max. cost for each account as required

here is the Data, feel feel to test it

[mdmackillop]

In your data, there are 58 Accounts where the Cost is 0 so no Maximum is available.

D & F are defined here


AC = Range(Cells(2, 4), Cells(Rows.Count, 4).End(xlUp)).Address
TCH = Range(AC).Offset(, 2).Address

[justdream]

You are right but I've detected 1 issue
in case you have repeated maximum value for Cost for same account
Macro didn't work well

Please check this sample
Could we fix it to get for example first row for highest cost value even if it;s repeated

[mdmackillop]

Option Explicit

Sub GetData()
Dim col As New Collection
Dim AC As Range, TCH As Range
Dim cel As Range, c As Range
Dim i, x As Single, y As Single
Dim FirstAddress As String
Set AC = Range(Cells(2, 4), Cells(Rows.Count, 4).End(xlUp))
Set TCH = AC.Offset(, 2)
On Error Resume Next
For Each cel In AC
col.Add cel, cel
Next
On Error GoTo 0
For Each i In col
y = Evaluate("=MAX(IF(" & AC.Address & "=" & """" & i & """" & "," & TCH.Address & "))")
With Range("F:F")
Set c = .Find(y, LookIn:=xlValues)
If Not c Is Nothing Then
FirstAddress = c.Address
Do
If c.Offset(, -2) = i Then
c.Interior.ColorIndex = 6 'for test purposes
x = c.Row
Exit Do
End If
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> FirstAddress
End If
End With
Cells(x, 1).Resize(, 38).Copy Sheets(2).Cells(Rows.Count, 1).End(xlUp)(2)
Next
End Sub

[justdream]

Sorry Mate,
I know I;m disturbing you a lot
New code sometimes work and sometimes give me

Run Time Error "1004":
Application Defined or object defined error

[mdmackillop]

It seems to be a night for "rounding" errors. Remove the Long Dim options to make this line.

Dim i, x, y