Excel 查找某一列中具有特定值的所有重复项，并从下一列返回值

我正在尝试做一件看起来像这样的东西：

Cells(i, "A").Value
Cells(i, "B").Value

在右边的表格中，将有存储在特定区域中的所有唯一记录。但是，某些记录可能存在于更多的区域中，此信息可以从A列和B列中的列表中获取。宏应获取D列中的每个唯一记录并在A列中搜索它，每次找到它时，都应复制B列中的位置/区域，并粘贴到表中唯一记录的旁边。我想我可以通过一个循环来实现这一点，但是我在下面的代码中创建的东西并不真正起作用

第二个挑战是让它明白，在已复制到表中的位置中，新找到的位置需要粘贴到该唯一记录的下一个空闲单元格中

我知道我的代码有点吓人，但即使只是建议我应该朝哪个方向看，我也会很感激。。。提前谢谢

Sub searcharea()

    Dim UC As Variant, UCrng As Range, ra As Range

    Set UCrng = Range("F2:F6")

    For Each UC In UCrng

        Set ra = Cells.Find(What:=UC, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate

        ra.Offset(0, 1).Copy Destination:=Range("E2")

    Next

End Sub

---

我建议循环遍历所有行（A+B列），例如：

对于每一行，如果A的值尚未存在，则将其复制到D中。 您可以访问如下值：

Cells(i, "A").Value
Cells(i, "B").Value

用于在列中查找值。如果发现重复项，请使用另一个循环检查特定行中的哪个列（E、F、G、…）是第一个空列，并超过该列B的值。

尝试一下：

Option Explicit

Sub test()

    Dim LastRowA As Long, LastRowD As Long, i As Long, rngColumn As Long
    Dim rng As Range

    With ThisWorkbook.Worksheets("Sheet1")

        LastRowD = .Cells(.Rows.Count, "D").End(xlUp).Row

        .Range("D2:J" & LastRowD).ClearContents

        LastRowA = .Cells(.Rows.Count, "A").End(xlUp).Row

        For i = 2 To LastRowA

            LastRowD = .Cells(.Rows.Count, "D").End(xlUp).Row

            Set rng = .Range("D1:D" & LastRowD).Find(.Range("A" & i).Value, LookIn:=xlValues, lookat:=xlWhole)

            If Not rng Is Nothing Then
                rngColumn = .Cells(rng.Row, .Columns.Count).End(xlToLeft).Column
                Cells(rng.Row, rngColumn + 1).Value = .Range("B" & i).Value
            Else
                .Range("D" & LastRowD + 1).Value = .Range("A" & i).Value
                .Range("E" & LastRowD + 1).Value = .Range("B" & i).Value
            End If

        Next i

    End With

End Sub

---

我想这段代码可以满足你的要求。请试一试

Option Explicit

Sub SortToColumns()
    ' Variatus @STO 30 Jan 2020

    Dim WsS As Worksheet                    ' Source
    Dim WsT As Worksheet                    ' Target
    Dim Rng As Range
    Dim Fn As String, An As String          ' File name, Area name
    Dim Rls As Long
    Dim Rs As Long
    Dim Rt As Long, Ct As Long

    With ThisWorkbook                       ' change as required
        Set WsS = .Worksheets("Sheet1")     ' change as required
        Set WsT = .Worksheets("Sheet2")     ' change as required
    End With

    With WsT
        ' delete all but the caption row
        .Range(.Cells(2, 1), .Cells(.Rows.Count, "A").End(xlUp)).EntireRow.ClearContents
    End With

    Application.ScreenUpdating = False
    With WsS
        ' find last row of source data
        Rls = .Cells(.Rows.Count, "A").End(xlUp).Row

        For Rs = 2 To Rls                   ' start from row 2 (row 1 is caption)
            Fn = .Cells(Rs, "A").Value
            An = .Cells(Rs, "B").Value
            If FileNameRow(Fn, WsT, Rt) Then
                ' add to existing item
                With WsT
                    Ct = .Cells(Rt, .Columns.Count).End(xlToLeft).Column
                    Set Rng = .Range(.Cells(Rt, "B"), .Cells(Rt, Ct))
                End With
                With Rng
                    Set Rng = .Find(An, .Cells(.Cells.Count), xlValues, xlWhole, xlByRows, xlNext)
                End With
                ' skip if Area exists
                If Rng Is Nothing Then WsT.Cells(Rt, Ct + 1).Value = An
            Else
                ' is new item
                WsT.Cells(Rt, "A").Value = Fn
                WsT.Cells(Rt, "B").Value = An
            End If
        Next Rs
    End With
    Application.ScreenUpdating = True
End Sub

Private Function FileNameRow(Fn As String, _
                             WsT As Worksheet, _
                             Rt As Long) As Boolean
    ' Rt is a return Long
    ' return True if item exists (found)

    Dim Fnd As Range
    Dim Rng As Range
    Dim R As Long

    With WsT
        R = .Cells(.Rows.Count, "A").End(xlUp).Row
        Set Rng = .Range(.Cells(2, "A"), .Cells(R, "A"))
        Set Fnd = Rng.Find(Fn, Rng.Cells(Rng.Cells.Count), xlValues, xlWhole, xlByRows, xlNext)

        If Fnd Is Nothing Then
            Rt = Application.Max(.Cells(.Rows.Count, "A").End(xlUp).Row + 1, 2)
        Else
            Rt = Fnd.Row
            FileNameRow = True
        End If
    End With
End Function

---

嗨，保罗，我不确定我是否明白了。。。我需要循环遍历D列，对于每一列，在A列中查找所有重复项。因此，我尝试使用find方法。我还需要复制表中的B列值，而不是A列值。好吧，我误解了你的问题。您可以使用For循环遍历所有行，并提取列D的值，您可以在A列中搜索D列的每个值。下一步是将B列的值粘贴到D后面的第一个空列中。我希望这能澄清我的答案。感谢@variatus，我将在周末前对其进行旋转！我会回来寻求反馈：）感谢@error1004和@error1004，我会在周末前让它转一转！我会回来寻求反馈：）