using vlookup to find matching values in a column - vba

Question

I have a column A with duplicate values inside it. I want to write a vlookup which does the following; If A has duplicate value inside it, the B value of this columns same row should be overwritten to previous A values same row in Column B.
An example for this ;
A B
1 Anna | 23 years old
2 Anna | 34 years old
So the value in B1 should be automatically 34 years old since the values in A column match.
How can i do this?

Answer 1

Try this:
Sub Demo()
Dim dict1 As Object
Dim c1 As Variant
Dim i As Long, lastRow As Long
Dim strFound As Range
Dim strFirst As String, copyVal As String
Set dict1 = CreateObject("Scripting.Dictionary")
lastRow = Cells(Rows.Count, "A").End(xlUp).Row '-->get last row with data in column A
'enter unique values of column A in dict1
c1 = Range("A1:A" & lastRow)
For i = 1 To UBound(c1, 1)
dict1(c1(i, 1)) = 1
Next i
For Each k In dict1.keys
'find last occurrence of each value in dict1
Set rngFound = Columns("A").Find(k, Cells(Rows.Count, "A"), xlValues, xlWhole, , xlPrevious)
If Not rngFound Is Nothing Then
'get column B value for found string
copyVal = rngFound.Offset(0, 1).Value
strFirst = rngFound.Address
Do
'find all the occurrences of each value in dict1
Set rngFound = Columns("A").Find(k, rngFound, xlValues, xlWhole, , xlPrevious)
'change value in column B for each occurrence
rngFound.Offset(0, 1).Value = copyVal
Loop While rngFound.Address <> strFirst
End If
Next k
End Sub
See image for reference:
EDIT# 1
________________________________________________________________________________
Sub Demo()
Application.ScreenUpdating = False
Dim dict1 As Object, dict2 As Object
Dim c1 As Variant
Dim i As Long, lastRow As Long
Dim strFound As Range, delRange As Range
Dim strFirst As String, copyVal As String
Set dict1 = CreateObject("Scripting.Dictionary")
Set dict2 = CreateObject("Scripting.Dictionary")
lastRow = Cells(Rows.Count, "A").End(xlUp).Row '-->get last row with data in column A
'enter unique values of column A in dict1
c1 = Range("A1:A" & lastRow)
For i = 1 To UBound(c1, 1)
dict1(c1(i, 1)) = 1
Next i
For Each k In dict1.keys
'find last occurrence of each value in dict1 and save row number in dict2
Set rngFound = Columns("A").Find(k, , xlValues, xlWhole, , xlPrevious)
If Not rngFound Is Nothing Then
dict2.add rngFound.Row, 1
End If
Next k
'check for column A if row number exists in dict2, if not then add to a range for deletion
For i = 1 To lastRow
If Not dict2.exists(Cells(i, 1).Row) Then
Debug.Print Cells(i, 1).Address
If delRange Is Nothing Then
Set delRange = Cells(i, 1)
Else
Set delRange = Union(delRange, Cells(i, 1))
End If
End If
Next i
'delete the range
If Not delRange Is Nothing Then
delRange.EntireRow.Delete
End If
Application.ScreenUpdating = True
End Sub
EDIT# 2
________________________________________________________________________________
Sub Demo()
Application.ScreenUpdating = False
Dim dict1 As Object, dict2 As Object
Dim c1 As Variant
Dim i As Long, lastRow As Long
Dim strFound As Range, delRange As Range
Dim rngFound As Range, rngFound1 As Range
Dim strFirst As String, copyVal As String
Set dict1 = CreateObject("Scripting.Dictionary")
Set dict2 = CreateObject("Scripting.Dictionary")
lastRow = Cells(Rows.Count, "B").End(xlUp).Row '-->get last row with data in column A
'enter unique values of column A in dict1
c1 = Range("B1:B" & lastRow)
For i = 1 To UBound(c1, 1)
dict1(c1(i, 1)) = 1
Next i
For Each k In dict1.keys
'find first occurrence of each value in dict1
Set rngFound = Columns("B").Find(k, , xlValues, xlWhole)
'find last occurrence of each value in dict1
Set rngFound1 = Columns("B").Find(k, , xlValues, xlWhole, , xlPrevious)
If rngFound.Address <> rngFound1.Address Then
rngFound.Offset(0, 1) = rngFound1.Offset(0, 1)
rngFound.Offset(0, 2) = rngFound1.Offset(0, 2)
If delRange Is Nothing Then
Set delRange = rngFound1
Else
Set delRange = Union(delRange, rngFound1)
End If
End If
Next k
'delete the range
If Not delRange Is Nothing Then
delRange.EntireRow.Delete
End If
Application.ScreenUpdating = True
End Sub