You can do this without using a VBA macro. We do need to add an
key column by combining Col A with Col B (
=A2&B2
) for each row. eg: next row will be:
=A3&B3
and so on....
Now we can filter unique companies. I will use a non-CSE (CTRL-SHIFT-ENTER) array formula:
=IFERROR(INDEX($E$2:$E$9, MATCH(0,INDEX(COUNTIF($G$1:G1,$E$2:$E$9),0,0),0)), "")
This will need to be done to several rows to find all unique values. How it works is by using the
key column value and comparing it to the row above it.
Now that we have all of the unique keys, we can now look for the max dates. This is a little more involved. We will be using the
AGGREGATE
function. This will need to be applied to each cell next to the unique results:
=AGGREGATE(14,4,($E$2:$E$9=G2)*$C$2:$C$9,1)
Okay, so, let us break down what this is doing:
1.
14
= Large / largest date value
2.
4
= Ignore Nothing
3.
($E$2:$E$9=G2)
= for all matching key rows
4.
*$C$2:$C$9
= for all dates
5. (3. & 4.)
($E$2:$E$9=G2)*$C$2:$C$9
= Logical test for only date cells that match the keys for steps 3., 4. 5., select the formula part in the edit formula bar and press the F9 key to see the array test true/false values. Multiplying booleans with booleans returns booleans ie: multiply a true (1) with a true (1), and you get true (1 x 1 = 1); multiply a False (0) with a True (1) or False(0) you get False (0 x 1 = 0 or 0 * 0 = 0)
6.
1
= the [k] selector is set for the first result
Here is a link to the solution:
Unique Companies with max date.xlsx | Google Drive[
^]. I have not hidden any rows or columns + I have added wrappers to the formulas to hide any errors or cells with results that we do not want to see. So they appear empty.
NOTE: Google Drive will want to open the spreadsheet in Google Sheets. If this happens,
Google Sheets does not support the Aggregate function and will throw a
#Name?
error. Do not worry, Select from the menu
File > Download > Microsoft Excel. Now open the downloaded spreadsheet in Excel and it will work as expected. (I just tested this 😉)
UPDATE
@Maciej Los suggested that a VBA solution was required, but gave an incomplete solution. So here is a complete VBA solution based on the above formulas...
Sub CompareAndCopy()
Dim selectRange As String
Dim keyRange As String
Dim resultKeyRange As String
Dim companyRange As String
Dim nameRange As String
Dim dateRange As String
Dim expandedRange As String
Dim resultDataRange As String
Dim dateCell As String
Dim resultIndex As Integer
Dim selRange As range
Dim UniqueRange As range
Dim index As Integer
selectRange = "$A$2:$C$7"
keyRange = "$D$2:$D$7"
companyRange = "$A$2:$A$7"
nameRange = "$B$2:$B$7"
dateRange = "$C$2:$C$7"
expandedRange = "$A$2:$D$7"
resultIndex = 8
resultKeyRange = "$D$9:$D$16"
resultDataRange = "$A$9:$D$16"
Set selRange = range(selectRange)
For Each Row In selRange.Rows
If Row.Cells(1, 1) <> "" Then
Row.Offset(0, 3).Cells(1, 1) =
Row.Cells(1, 1) + Row.Cells(1, 2)
End If
Next
Set UniqueRange = range(resultDataRange)
UniqueRange.Clear
Set UniqueRange = range(resultKeyRange)
index = resultIndex
For Each cell In UniqueRange.Rows
cell.Formula = "=IFERROR(INDEX(" + keyRange + _
", MATCH(0,INDEX(COUNTIF($D$8:D" + CStr(index) + _
"," + keyRange + "),0,0),0)), """")"
index = index + 1
Next
Set selRange = range(expandedRange)
Set UniqueRange = range(resultDataRange)
index = resultIndex + 1
For Each Row In UniqueRange.Rows
dateCell = "$D" + CStr(index)
If Not IsEmpty(range(dateCell).Value) Then
Row.Offset(0, 0).Cells(1, 1).Formula = "=IF(" + dateCell + _
" <> """",INDEX(" + companyRange +
",MATCH(" + dateCell + "," + keyRange + ",0)), """")"
Row.Offset(0, 1).Cells(1, 1).Formula = "=IF(" + dateCell + _
" <> """",INDEX(" + nameRange +
",MATCH(" + dateCell + "," + keyRange + ",0)), """")"
Row.Offset(0, 2).Cells(1, 1).Formula = "=IF(" + dateCell + _
" <> """",AGGREGATE(14,4,(" + keyRange +
"=" + dateCell + ")*" + dateRange + ",1), """")"
index = index + 1
End If
Next
Columns("C:C").Select
Selection.NumberFormat = "m/d/yyyy"
Range("A1").Select
End Sub
If you want to remove the keys and make the results static data (values, not formulas) then you could add this at the end:
range(resultDataRange).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
range(keyRange).Select
Application.CutCopyMode = False
Selection.ClearContents
range(resultKeyRange).Select
Application.CutCopyMode = False
Selection.ClearContents
Spreadsheet link updated with the new VBA macro is:
Unique Companies with max date.xlsm - Google Drive[
^] ... again, opens like a Google Sheet and there is a Download button in the top right corner. 😉
Download and have a look to see how it works.
Enjoy!