Macro Magic Required

[mikemcbain]

I use Office 365 and xlsx and xlsm and the occasional old xls file.
I have a large xls workbook which includes Sheets called Today and Best.
On my Today sheet which changes each day I have Columns E to CH sorted by Column Z which has dates in descending Date order, somedays just one Row per Date but somedays there can be up to 20 Rows with the same Date and perhaps 50 different dates.Column N called ARATE is a secondary sort column.
Now here is my problem....I want to copy only the first Row of each date to my worksheet called Best.
I will attach a before and after screen shot
It is so tedious doing it manually.
With thanks for your patience and assistance.
Old Mike.

 

[Michael M]

You could copy the entire set of data to the "Best" sheet then run this code on that sheet

Sub MM1()
 Dim lr As Long, r As Long
 lr = Cells(Rows.Count, "Z").End(xlUp).Row
For r = lr To 2 Step -1
    If Cells(r, "Z") = Cells(r - 1, "Z") Then Rows(r).Delete
Next r
End Sub

 

[mikemcbain]

You could copy the entire set of data to the "Best" sheet then run this code on that sheet

Sub MM1()
Dim lr As Long, r As Long
lr = Cells(Rows.Count, "Z").End(xlUp).Row
For r = lr To 2 Step -1
    If Cells(r, "Z") = Cells(r - 1, "Z") Then Rows(r).Delete
Next r
End Sub

Michael M that is a truly magic response thank you!
Solved in less than 15 minutes what a wonderful service this Forum provides.
Forever grateful
Old MikeM

 

[Michael M]

Us Old Mikes have to stick together...

 

[Michael M]

This will copy the "Today" data across for you as well !!

Sub MM1()
 Dim lr As Long, r As Long
 Sheets("Today").UsedRange.Copy Sheets("Best").Range("A1")
With Sheets("Best")
    lr = .Cells(Rows.Count, "Z").End(xlUp).Row
    For r = lr To 2 Step -1
      If .Cells(r, "Z") = .Cells(r - 1, "Z") Then .Rows(r).Delete
    Next r
End With
End Sub

 

[mikemcbain]

This will copy the "Today" data across for you as well !!

Sub MM1()
Dim lr As Long, r As Long
Sheets("Today").UsedRange.Copy Sheets("Best").Range("A1")
With Sheets("Best")
    lr = .Cells(Rows.Count, "Z").End(xlUp).Row
    For r = lr To 2 Step -1
      If .Cells(r, "Z") = .Cells(r - 1, "Z") Then .Rows(r).Delete
    Next r
End With
End Sub

Thanks again Michael - I will use that as well.

Us Old Mikes have to stick together...

I turned 68 the day after you joined this Forum!

 

[Michael M]

Hmm....I'm 68 next month....so you have me covered...

 

[Peter_SSs]

What about removing all the unwanted rows at once instead of looping a row at a time?
This code also clears columns E:CH on 'Best' of any existing data and does the copy of those columns to that sheet before removing the unwanted rows.
If you have data in other columns (not mentioned or shown) & want that copied across too, post back with details.

BTW, I suggest that you investigate XL2BB for providing sample data to make it easier for helpers by not having to manually type out sample data to test with.

Sub FirstDateOnly()
  Sheets("Best").Columns("E:CH").Clear
  Sheets("Today").Range("E:CH").Copy Destination:=Sheets("Best").Range("E1")
  Sheets("Best").Columns("E:CH").RemoveDuplicates Columns:=22, Header:=xlYes
End Sub

 

[mikemcbain]

What about removing all the unwanted rows at once instead of looping a row at a time?
This code also clears columns E:CH on 'Best' of any existing data and does the copy of those columns to that sheet before removing the unwanted rows.
If you have data in other columns (not mentioned or shown) & want that copied across too, post back with details.

BTW, I suggest that you investigate XL2BB for providing sample data to make it easier for helpers by not having to manually type out sample data to test with.

Sub FirstDateOnly()
  Sheets("Best").Columns("E:CH").Clear
  Sheets("Today").Range("E:CH").Copy Destination:=Sheets("Best").Range("E1")
  Sheets("Best").Columns("E:CH").RemoveDuplicates Columns:=22, Header:=xlYes
End Sub

Thanks Peter after a little struggle I have managed to install Mr Excell and Capture Range on my ribbon for future use. Yes I do have data in all of those columns Now I will experiement with your code thank you.

 

[Peter_SSs]

I have managed to install Mr Excell and Capture Range on my ribbon for future use.

Great!

Yes I do have data in all of those columns

In that case I would suggest this which removes the 'Best' sheet (code assumes that sheet does exist) and duplicates 'Today' which would preserve all formatting, column widths etc before removing the required rows all at the one time on the new 'Best' sheet.

Sub FirstDateOnly_v2()
  Application.DisplayAlerts = False
  Sheets("Best").Delete
  Application.DisplayAlerts = True
  Sheets("Today").Copy After:=Sheets("Today")
  With ActiveSheet
    .UsedRange.RemoveDuplicates Columns:=26, Header:=xlYes
    .Name = "Best"
  End With
End Sub