VBA Check duplicates (column) and copy cells from one row to another that is duplicate

0
votes

Excel 2007 [VB] In my macro I filter by color to find duplicated values (on column "J" I have Highlight Cells Rules - Duplicates). Duplicated records in column "J" are named in column "K" as "Copy" or "Original".I would like to find "Copy" for each "Original" record which is always under (but not 1 but more rows) and copy cells value from column N:R of "Copy" row to row with "Original".

I hope I wrote it clearly but if not screenshot under.

Table

enter image description here

Begining of my macro:

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

I looked for something similiar that can help and I found such a scripts:

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

But to be honest I can't figure it out how to connect it into one working macro. I would be gratefull for help.

2
excelvba

2 Answers

0
votes

Try this:

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

0
votes

You can try that;

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