如果一个单元格在一列中找到两次，则将单元格的内容粘贴到找到的单元格旁边

Question

我目前正在尝试编写一个宏，我可以使用该宏检查 A 列中是否有任何值多次。如果有一个值两次，我希望宏复制双倍单元格旁边的单元格的值并将其粘贴到原始单元格旁边的单元格中，除以它粘贴的单元格的内容“；”。我知道这句话很复杂，但我发现很难描述我的问题。 This is the worksheet not "damaged" by my macro

我刚才描述的东西或多或少都有效，我遇到的问题是，如果有一个单元格多次具有相同的内容，并且旁边的单元格也具有相同的值，那么从逻辑上讲，宏将在值中也是如此。我真的不知道如何阻止它。此外，到目前为止，我的宏如果存在两次的单元格旁边的单元格为空，则宏可能会导致放置许多不需要的“;”。

This is after my macro "destroyed" the sheet

我对 VBA 还是很陌生，非常感谢我能得到的任何帮助！

编辑： 这是我到目前为止的想法

Option Explicit

Sub Dopplungen()

Dim rng As Range, rng2 As Range, rcell As Range, rcell2 As Range, valueold As String, valuenew As String

Set rng = ThisWorkbook.Sheets("Data").Range("A2:A500")

For Each rcell In rng.Cells
    If rcell.Value <> vbNullString Then
        For Each rcell2 In rng.Cells
            If rcell.Value = rcell2.Value Then
                If rcell.Address <> rcell2.Address Then
                    valueold = rcell.Offset(0, 1).Value
                    valuenew = rcell2.Offset(0, 1).Value
                    If rcell.Offset(0, 1).Value <> rcell2.Offset(0, 1).Value Then
                        If rcell2.Offset(0, 1).Value <> "" Then
                            If rcell.Offset(0, 1).Value <> "" Then
                            rcell.Offset(0, 1).Value = valueold & ";" & valuenew
                            Else
                            rcell.Offset(0, 1).Value = valuenew
                            End If
                        End If
                    End If
                End If
            End If
        Next rcell2
    End If
Next rcell
End Sub

Answer 1

一种可能性是使用Dictionary 对象，该对象具有唯一的键

喜欢这个代码（cmets 中的解释）：

Option Explicit

Sub main()
    Dim fruitRng As Range
    Dim cell As Range

    With Worksheets("fruits") 'change "fruits" to your actual worksheet name
        Set fruitRng = .Range("B1", .Cells(.Rows.Count, 1).End(xlUp)) 'get its range in columns "A:B" from row 1 down to column A last not empty cell
    End With

    With CreateObject("Scripting.Dictionary")
        For Each cell In fruitRng.Columns(1).Cells 'first loop to get unique fruit names and associate them a dictionary
            Set .Item(cell.Value) = CreateObject("Scripting.Dictionary")
        Next

        For Each cell In fruitRng.Columns(1).Cells 'second loop to fill each fruit dictionary with its color
            If cell.Offset(, 1).Value <> "" Then 'mind only not empty color cells
                With .Item(cell.Value) 'reference the current fruit dictionary
                    .Item(cell.Offset(, 1).Value) = .Item(cell.Offset(, 1).Value) 'add current color in its keys, so you get a unique list of them
                End With
            End If
        Next

        For Each cell In fruitRng.Columns(1).Cells 'third loop to finally write down the colors next to each fruit
            cell.Offset(, 1).Value = Join(.Item(cell.Value).Keys, ";")
        Next
    End With
End Sub