using vlookup to find matching values in a column

问题

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?

回答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

来源：https://stackoverflow.com/questions/38048364/using-vlookup-to-find-matching-values-in-a-column