在一列中查找重复项，然后将数据复制到 VBA 中的其他列

Question

我正试图在 VBA 中弄清楚当数据有重复项时如何复制和粘贴数据。

我想做的是。

如果单元格 A1、A2 和 A3 重复我想把H1的数据复制粘贴到H2,H3

到目前为止，我只能设法在 A 列中找到重复项，但卡住了找到我的问题的解决方案。

Sub Doubles()
'
' Doubles Macro
' Les Doubles
'
' Touche de raccourci du clavier: Ctrl+e
'
    Range("A1:I128").Select
    ActiveWindow.SmallScroll Down:=-123
    Selection.AutoFilter
    Range("A:A,H:H").Select
    Range("H1").Activate
    Selection.FormatConditions.AddUniqueValues
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    Selection.FormatConditions(1).DupeUnique = xlDuplicate
    With Selection.FormatConditions(1).Font
        .Color = -16383844
        .TintAndShade = 0
    End With
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 13551615
        .TintAndShade = 0
    End With
    Selection.FormatConditions(1).StopIfTrue = False
    ActiveSheet.Range("$A:$I8").AutoFilter Field:=1, Criteria1:=RGB(255, _
        199, 206), Operator:=xlFilterCellColor
    ActiveSheet.AutoFilter.Sort.SortFields.Clear
    ActiveSheet.AutoFilter.Sort.SortFields.Add Key:= _
        Range("A1:A128"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
        :=xlSortNormal
    With ActiveSheet.AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

Answer 1

运行子之前的示例数据：

在column-A的行中，有一些重复的值。

if cells A1, A2 and A3 are duplicates I want to copy the data of H1 and paste it to H2, H3

子假设在 column-A 中的每个重复值中，只有一行具有 column-H 中的值。例如：在 column-A 中，JOHN 出现在单元格 A5、A10、A17 ---> 因此在 column-H 中，具有值的行将在单元格 H5 或 H10 或 H17 中。在上面的图像示例中，只有单元格 H5 具有值。

预期结果（来自上图）：
单元格 H5、H10 和 H17 的值为“john”
单元格 H6 和 H18 的值为“khan”
等等

Sub test()
Dim arr As Variant: Dim el
Dim rg As Range: Dim cell As Range

With Sheets("Sheet1")
Set rg = .Range("A1", .Range("A" & Rows.Count).End(xlUp))
End With

Set arr = CreateObject("scripting.dictionary")
For Each cell In rg: arr.Item(cell.Value) = 1: Next

For Each el In arr
    If Application.CountIf(rg, el) > 1 Then
        With rg
            .Replace el, True, xlWhole, , False, , False, False
            .SpecialCells(xlConstants, xlLogical).Offset(0, 7).Value = .SpecialCells(xlConstants, xlLogical).Offset(0, 7).SpecialCells(xlConstants).Value
            .Replace True, el, xlWhole, , False, , False, False
        End With
    End If
Next

End Sub

宏过程：

用 column-A 中的数据创建一个范围到变量 rg
从 rg 中的唯一值创建一个数组作为变量 arr
循环到arr
检查元素在 rg 中出现了多少次
如果元素在 rg 中出现不止一次（例如：JOHN）
它将 rg 中的元素名称替换为逻辑 TRUE（现在 column-A 中的 JOHN 变为 TRUE）
然后它获取 rg 中所有具有 TRUE 值的单元格（单元格 A5、A10、A17）
然后将这些单元格向右偏移 7（单元格 H5、H10、H17）
然后用值填充它们---对不起，我很难用英语解释它---。（用H5值填充H5、H10、H17）。
然后将 rg 中的 TRUE 值带回元素的名称（现在 column-A 中的 TRUE 再次成为 JOHN）。

if cells A1, A2 and A3 are duplicates I want to copy the data of H1 and paste it to H2, H3

再次请记住，代码假定只有一个单元格具有值。从上面的引述来看，只有单元格 H1 具有值，H2 和 H3 是 blank/empty/no-value.

示例：
单元格 A100、A200、A300、A400、A500 重复。
如果在 H100 中有一个值并且在 H500 中有一个值，则代码将不会运行正确。同样，必须只有一个单元格具有值，它在 H100 或 H200 或 H300 或 H400 或 H500 中。

在一列中查找重复项，然后将数据复制到 VBA 中的其他列

Find Duplicates in a column then copy data to other column in VBA

excel

vba

copy-paste

excel-formula