Question

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

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

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对象，该对象具有唯一键的属性

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

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

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

1 个答案: