VBA检查重复项（列）并将单元格从一行复制到另一行是重复的

Question

Excel 2007 [VB] 在我的宏中，我按颜色过滤以查找重复的值（在列＆＃34; J＆＃34;我有突出显示单元格规则 - 重复）。列＃34; J＆＃34;中的重复记录列于＆＃34; K＆＃34; as＆＃34;复制＆＃34;或＆＃34;原创＆＃34;。我想找到＆＃34;复制＆＃34;对于每个＆＃34; Original＆＃34;总是在（但不是1行，但更多行）的记录和从N列复制单元格值：R＆＃34;复制＆＃34;行与＃34;原始＆＃34;。

我希望我写清楚但如果不是截图。

表

开始我的宏：

Sub copy_original()
Dim lastRow As Long
Dim wb2 As Excel.Workbook

Application.DisplayAlerts = False
Application.AlertBeforeOverwriting = False
Application.ScreenUpdating = True

Set wb2 = ThisWorkbook

wb2.Sheets("Sheet1").AutoFilterMode = False
wb2.Sheets("Sheet1").Range("A4:U4").AutoFilter Field:=10, Criteria1:=RGB(255, 204, 0), Operator:=xlFilterCellColor

lastRow = wb2.Sheets("Sheet1").Cells(Rows.Count, "C").End(xlUp).Row

For x = lastRow To 5 Step -1
If...
...
wb2.Sheets("Sheet1").AutoFilterMode = False
End Sub

我找了一些可以提供帮助的东西，我找到了这样的脚本：

Check if one cell contains the EXACT same data as another cell VBA

Find cells with same value within one column and return values from separate column of same row

Excel: Check if Cell value exists in Column, and return a value in the same row but different column

但说实话，我无法弄清楚如何将它连接到一个工作宏。 我很感激你的帮助。

Answer 1

你可以试试;

For x = 5 to lastRow
   If Cells(x,11) = "Copy" Then
      For y = x+1 to LastRow
         If Cells(y,10).Value = Cells(x,10) then
            Cells(y,14) = Cells(x,14)
            Cells(y,15) = Cells(x,15)
            Cells(y,16) = Cells(x,16)
            Cells(y,17) = Cells(x,17)
            Cells(y,18) = Cells(x,18)
         End If
      Next y
   End If
Next x

Answer 2

试试这个：

Sub copy_original（）     Dim filteredRng As Range，cl As Range，rw As Integer

Application.DisplayAlerts = False
Application.AlertBeforeOverwriting = False
Application.ScreenUpdating = True

With ThisWorkbook.Worksheets("Sheet1")

    .AutoFilterMode = False
    .Range("A4:U4").AutoFilter Field:=10, Criteria1:=vbRed, Operator:=xlFilterCellColor

    Set filteredRng = .Range("J5:J" & .Cells(Rows.Count, "J").End(xlUp).Row)

    For Each cl In filteredRng.SpecialCells(xlCellTypeVisible)
        If cl.Offset(0, 1) = "Original" Then
            Range("L" & rw & ":R" & rw).Copy Destination:=cl.Offset(0, 2)
        End If
        rw = cl.Row
    Next cl

    .AutoFilterMode = False
End With

End Sub