VBA for make resume by date (Unique & No Duplicate)

[omegaboost]

Dear All,

I have the the table as shown in Sheet 1 which contain column Date, Name, Doc1, Doc2 and i have to make resume as shown in Sheet 2. In that Resume, the data sorted by date 7 May 2017 (D1) and should be shorted ascending and unique (no duplication).
Just wondering how to solve this matter by VBA?

Thank you

Best Regards

Omega Boost

[mdmackillop]

Option Explicit


Sub Test()
Dim r As Range, c As Range
Dim rw As Long
Dim rT As Long, rB As Long
Dim i As Long, j As Long
Rows("1:4").Insert
Columns("D:E").Cut
Columns("B:C").Insert
Range("C1") = "Date:"
Range("E1") = Date - 3 'Adjust to suit
rT = Columns(1).Find("Date").Row
rB = Cells(Rows.Count, 1).End(xlUp).Row
For i = rT To rB
Cells(i, 4) = Cells(i, 2) & Cells(i, 3) & Cells(i, 5)
Next i
For i = rB To rT + 1 Step -1
If DateValue(Cells(i, 1)) <> DateValue(Cells(1, 5)) Then
Rows(i).Delete
Else
Set c = Columns(4).Find(Cells(i, 4).Value, after:=Cells(i, 4), searchdirection:=xlPrevious)
If Not c Is Nothing And c.Address <> Cells(i, 4).Address Then Rows(i).Delete
End If
Next i
Columns("D:D").Delete
Columns("A:A").NumberFormat = "General"
rT = Columns(1).Find("Date").Row
rB = Cells(Rows.Count, 1).End(xlUp).Row
Cells(rT, 1) = "No"
For i = rT + 1 To rB
j = j + 1
Cells(i, 1) = j
Next i
End Sub

[omegaboost]

Dear mdmackillop,

Thank you for your response and i appreciate it. Actually what i need is the VBA to make resume by date or populate the data from table in Sheet 1 to be show on table in Sheet 2 and the data in Sheet 2 should be unique (no duplication). So, if we change the date on Sheet 2 (cell D1), we will get the unique data from the table on Sheet1 which corresponds to the data for that date.
No need to change the format of both tables, only the value will change.
Thank you in advance

Omega boost

[mdmackillop]

Sheet2 module

Option Explicit


Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$D$1" Then Call Test
End Sub


Standard module

Option Explicit


Sub Test()
Dim r As Range, c As Range
Dim rw As Long
Dim rT As Long, rB As Long
Dim i As Long, j As Long
Dim sh As Worksheet

Application.ScreenUpdating = False
Sheets("Sheet1").Copy after:=Sheets(Sheets.Count)
Set sh = ActiveSheet

With sh
.Columns("D:E").Cut
.Columns("B:C").Insert
rT = .Columns(1).Find("Date").Row
rB = .Cells(Rows.Count, 1).End(xlUp).Row
For i = rT To rB
Cells(i, 4) = Cells(i, 2) & Cells(i, 3) & Cells(i, 5)
Next i
For i = rB To rT + 1 Step -1
If DateValue(.Cells(i, 1)) <> DateValue(Sheets("Sheet2").Cells(1, 4)) Then
.Rows(i).Delete
Else
Set c = Columns(4).Find(Cells(i, 4).Value, after:=Cells(i, 4), searchdirection:=xlPrevious)
If Not c Is Nothing And c.Address <> Cells(i, 4).Address Then Rows(i).Delete
End If
Next i
.Columns("D:D").Delete
.Columns("A:A").NumberFormat = "General"
rT = Columns(1).Find("Date").Row
rB = Cells(Rows.Count, 1).End(xlUp).Row
For i = rT + 1 To rB
j = j + 1
.Cells(i, 1) = j
Next i
Sheets("Sheet2").Cells(6, 1).Resize(22, 4).ClearContents
.Cells(rT, 1).CurrentRegion.Offset(1).Copy

Sheets("Sheet2").Cells(6, 1).PasteSpecial Paste:=xlValues
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
Application.Goto Sheets("Sheet2").Cells(6, 1)
End With
Application.ScreenUpdating = True
End Sub