copy cell if row matches

Hi, light,

is there an unique identifier for the data sets like the item in Column A? If not could we add a new column A to both sheets and concatenate the values for Columns 2 to 7 to show the search criteria? Will there always be just one match or might there be more than one match?

With the newly created searchcriteria you could use a loop for sheet3 using only the cells with data by using SpecialCeclls(xlCellTypeConstants, 23) and using a For Each rngCell in range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row).SpecialCells(xlCellTyoeConstants, 23), use WorksheetFunction:CountIf to check if this item is available on Sheet2, use Find for Column A on Sheet2 if the result is greater than 0, set a range to the first found, copy over by using the rows of the ranges as part of the cells. At the end of the macro delete the first column on both sheets. Not that complicated, is it?

Ciao,
Holger

In looking for a macro to this problem, I have come across methods that say to use a unique identifier but this does not apply in this case.

I do have a macro that checks the first 6 cells on a sheet for duplicates and if they are identical deletes the duplicate row(s). That macro is performed on sheet 2 to clean it up. I'm just not sure how to turn the macro into checking for identical rows between 2 sheets and not deleting but adding a copied value to the end of all rows on sheet 3. This is what I have that identifies duplicates between the first 8 cells (I can change it to 6 or whatever)on the same sheet then deletes them. I'm sure it can be modified to check for identical rows in the first 6 cells between sheets and do a copy/loop.

Sub TestForDups()

   Dim LLoop As Integer
   Dim LTestLoop As Integer
   Dim Lrows As Integer
   Dim LRange As String
   Dim LCnt As Integer
   
   'Column values
   Dim LColA_1, LColB_1, LColC_1, LColD_1, LColE_1, LColF_1, LColG_1, LColH_1, LColI_1, LColJ_1 As String
   Dim LColA_2, LColB_2, LColC_2, LColD_2, LColE_2, LColF_2, LColG_2, LColH_2, LColI_2, LColJ_2 As String
   
   'Test first 2000 rows in spreadsheet for duplicates (delete any duplicates found)
   Lrows = 2000
   LLoop = 2
   LCnt = 0
   
   'Check first 2000 rows in spreadsheet
   While LLoop <= Lrows
      LColA_1 = "A" & CStr(LLoop)
      LColB_1 = "B" & CStr(LLoop)
      LColC_1 = "C" & CStr(LLoop)
      LColD_1 = "D" & CStr(LLoop)
      LColE_1 = "E" & CStr(LLoop)
      LColF_1 = "F" & CStr(LLoop)
      LColG_1 = "G" & CStr(LLoop)
      LColH_1 = "H" & CStr(LLoop)
      LColI_1 = "I" & CStr(LLoop)
      LColJ_1 = "J" & CStr(LLoop)
      
      If Len(Range(LColA_1).Value) > 0 Then
      
         'Test each value for uniqueness
         LTestLoop = LLoop + 1
         While LTestLoop <= Lrows
            If LLoop <> LTestLoop Then
               LColA_2 = "A" & CStr(LTestLoop)
               LColB_2 = "B" & CStr(LTestLoop)
               LColC_2 = "C" & CStr(LTestLoop)
               LColD_2 = "D" & CStr(LTestLoop)
               LColE_2 = "E" & CStr(LTestLoop)
               LColF_2 = "F" & CStr(LTestLoop)
               LColG_2 = "G" & CStr(LTestLoop)
               LColH_2 = "H" & CStr(LTestLoop)
               LColI_2 = "I" & CStr(LTestLoop)
               LColJ_2 = "J" & CStr(LTestLoop)
               
               
               'Value has been duplicated in another cell (based on values in columns A to J)
               If (Range(LColA_1).Value = Range(LColA_2).Value) _
                And (Range(LColB_1).Value = Range(LColB_2).Value) _
                And (Range(LColC_1).Value = Range(LColC_2).Value) _
                And (Range(LColD_1).Value = Range(LColD_2).Value) _
                And (Range(LColE_1).Value = Range(LColE_2).Value) _
                And (Range(LColF_1).Value = Range(LColF_2).Value) _
                And (Range(LColG_1).Value = Range(LColG_2).Value) _
                And (Range(LColH_1).Value = Range(LColH_2).Value) _
                And (Range(LColI_1).Value = Range(LColI_2).Value) _
                And (Range(LColJ_1).Value = Range(LColJ_2).Value) Then

                
                
                  'Delete the duplicate
                  Rows(CStr(LTestLoop) & ":" & CStr(LTestLoop)).Select
                  Selection.Delete Shift:=xlUp
                  
                  'Decrement counter since row was deleted
                  LTestLoop = LTestLoop - 1
                  
                  LCnt = LCnt + 1
                  
               End If
               
            End If
            
            LTestLoop = LTestLoop + 1
         Wend
         
      End If
      
      LLoop = LLoop + 1
   Wend
   
   'Reposition back on cell A1
   Range("A1").Select
   MsgBox CStr(LCnt) & " rows have been deleted."
   
End Sub

Hi, light,

you should add code-tags to your procedure as requested by Forum Rule #3.

Please try this code on a copy of your workbook:

Sub EF973682()

'http://www.excelforum.com/excel-programming-vba-macros/973682-copy-cell-if-row-matches.html

Dim wsTarg          As Worksheet
Dim wsData          As Worksheet
Dim lngLRData       As Long
Dim lngLRTarg       As Long
Dim rngCell         As Range
Dim wsf             As WorksheetFunction
Dim var             As Variant

Const cstrTARG      As String = "Sheet3"  'Sheet to write to
Const cstrDATA      As String = "Sheet2"  'Sheet to hold the data
Const cstrCOL_DATA  As String = "I"       'original column to get data from
Const cstrCOL_TARG  As String = "O"       'original column to write data to

On Error GoTo exit_here
Set wsTarg = Sheets(cstrTARG)
Set wsData = Sheets(cstrDATA)

lngLRData = wsData.Range("A" & Rows.Count).End(xlUp).Row
lngLRTarg = wsTarg.Range("A" & Rows.Count).End(xlUp).Row

wsData.Range("A1").EntireColumn.Insert
wsData.Range("A1").Value = "Temp"
With wsData
  .Activate
  .Range("A2:A" & lngLRData) = Evaluate("B2:B" & lngLRData & "&"" ""&C2:C" & lngLRData & "&"" ""&D2:D" & lngLRData _
       & "&"" ""&E2:E" & lngLRData & "&"" ""&F2:F" & lngLRData & "&"" ""&G2:G" & lngLRData)
End With

wsTarg.Range("A1").EntireColumn.Insert
wsTarg.Range("A1").Value = "Temp"
With wsTarg
  .Activate
  .Range("A2:A" & lngLRTarg) = Evaluate("B2:B" & lngLRTarg & "&"" ""&C2:C" & lngLRTarg & "&"" ""&D2:D" & lngLRTarg _
      & "&"" ""&E2:E" & lngLRTarg & "&"" ""&F2:F" & lngLRTarg & "&"" ""&G2:G" & lngLRTarg)
  For Each rngCell In .Range("A2:A" & lngLRTarg).SpecialCells(xlCellTypeConstants, 23)
    var = Application.Match(rngCell.Value, wsData.Range("A1:A" & lngLRData), 0)
    If Not IsError(var) Then
      .Range(cstrCOL_TARG & rngCell.Row).Offset(0, 1).Value = wsData.Range(cstrCOL_DATA & var).Offset(0, 1).Value
    End If
  Next rngCell
End With

exit_here:
If wsTarg.Range("A1").Value = "Temp" Then
  wsTarg.Range("A1").EntireColumn.Delete
End If
If wsData.Range("A1").Value = "Temp" Then
  wsData.Range("A1").EntireColumn.Delete
End If

Set wsf = Nothing
Set wsData = Nothing
Set wsTarg = Nothing

End Sub

Ciao,
Holger