Compare values of two range of cells and copy entire row

[vadius]

Hello guys

I have two sheets : the first one contains all the source data, the second one contains some of those data.
I want to build a macro that compares the values of the first four cells in each row of sheet(1) with those of sheets (2) and if equal, then copies the entire row of sheets(2) into a sheet(3), else copies the entire row of sheets(1) into sheet(3).

The rationale behind is the following : Data from sheet(1) are updated automatically from an independant database, and in sheet(2) I change manually some of the values (But I keep the values of the first four cells of each row so that I compare). Sheet(3) combines both.

Below my macro : I don't know how to specify the range of cells to compare between sheet(1) and sheet(2) neither how to ask the macro compare those values. If equal then copy the entire row...

Below Worksheets("Index_Div_Source") is sheet(1) and Worksheets("Index_Div_Manual") is sheet(2) . Sourcecel are the first four cells of each row in the sheet(1) and manualcel the first four cell of each row in sheet(3). Worksheets("Index_Div_Final") is sheet(3) where I want to combine everything.

Hope it's clear,

Thanks you


[vba]Sub Compare()

Dim i As Integer
Dim manualcel As Range
Dim sourcecel As Range

Dim lastrow As Integer

Application.ScreenUpdating = False

lastrow = Worksheets("Index_Div_Source").Range("A65536").End(xlUp).Row


With Worksheets("Index_Div_Final")

For i = 3 To lastrow

Set manualcel = Worksheets("Index_Div_Manual").Range("A" & i, "D" & i)

For Each sourcecel In Worksheets("Index_Div_Source").Range("A" & i, "D" & i)

If sourcecel.Value = manualcel.Value Then

Worksheets("Index_Div_Manual").Range("A" & i).EntireRow.Copy
Worksheets("Index_Div_Final").Range("A" & i).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

Else

Worksheets("Index_Div_Source").Range("A" & i).EntireRow.Copy
Worksheets("Index_Div_Final").Range("A" & i).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False


End If

Next

Application.ScreenUpdating = True

Next

End With


End Sub
[/vba]

[mancubus]

hi.

try below, and if it works, do not ask me how i've done that.

[VBA]
Sub CopyUniqueBasedOnFourCols()

Dim a, i, j, k, n, b(), z, ws()
Dim ws1 As Worksheet, ws2 As Worksheet

Set ws2 = Sheets("Index_Div_Final")

ReDim ws(1 To 2)
ws(1) = "Index_Div_Manual"
ws(2) = "Index_Div_Source"

ReDim b(1 To 5000, 1 To 17)
With CreateObject("Scripting.Dictionary")
.CompareMode = vbTextCompare
For k = 1 To 2
Set ws1 = Sheets(ws(k))
a = ws1.Range("A2:Q" & ws1.Cells(Rows.Count, 1).End(xlUp).Row).Value
For i = 1 To UBound(a, 1)
If Not IsEmpty(a(i, 2)) Then
z = a(i, 1) & ":" & a(i, 2) & ":" & a(i, 3) & ":" & a(i, 4)
If Not .exists(z) Then
n = n + 1
For j = 1 To 17
b(n, j) = a(i, j)
Next
.Add z, n
End If
End If
Next i
Set ws1 = Nothing
Next k
End With

ws2.Range("A2:Q5000").ClearContents
ws2.Range("A2").Resize(n, 17).Value = b

Set ws2 = Nothing

End Sub
[/VBA]

[mancubus]

edit:
requires a reference to Microsoft Scripting Runtime