VBA重複（列）を確認し、ある行から別の行にセルをコピーします。

Question

Excel 2007 [VB] マクロで重複値を検出するために色でフィルターをかけます（ "J"列に重複セルの規則 - 重複）。列 "J"の重複したレコードは、 "K"列に "Copy"または "Original"という名前が付けられます。常に存在する（ただし1行以上はない） "Original"レコードの "Copy" 「コピー」行の列N：Rからのセル値を「オリジナル」の行にコピーする。

私はそれをはっきりと書きましたが、スクリーンショットが表示されていないことを願っています。

表

私のマクロの初め：

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

：

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 

ことを助けることができると私はそのようなスクリプトを見つけ似私は何かを探しました

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

しかし、私は1つの作業マクロにそれを接続するためにどのようにそれを把握することはできません正直に言うと。 私は助けに感謝します。

Answer 1

このお試しください：整数

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の

Answer 2

これを試すことができます。

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