Solved: Data Duplication Problem

[deedii]

Guys a lil help here. I am sorting my code the problem why it keeps duplicating the data when i run the macro when it supposed to add only the new entry not duplicate the existing data. Am i missing something with this code?

[vba]
Sub copy_2()

Dim x(), y(), rez(), i&, j&, lr&, s$

With Sheets("Sheet2")
x = .Range("A2:T" & .Cells(Rows.Count, 1).End(xlUp).Row).Value
lr = .Cells(Rows.Count, "A").End(xlUp).Row + 1
End With
With Sheets("Sheet1")
y = .Range("A2:X" & .Cells(Rows.Count, 1).End(xlUp).Row).Value
End With
ReDim rez(1 To UBound(y), 1 To 24)

On Error Resume Next
With New Collection
If IsArray(x) Then
For i = 1 To UBound(x)
s = Trim(x(i, 1)) & Trim(x(i, 2))
If IsEmpty(.Item(s)) Then .Add 0, s
Next i
End If

For i = 1 To UBound(y)
If Trim(y(i, 12)) = "transfer" Then
s = Trim(y(i, 1)) & Trim(y(i, 2))
If IsEmpty(.Item(s)) Then
j = j + 1
rez(j, 1) = y(i, 1)
rez(j, 3) = y(i, 2)
rez(j, 4) = y(i, 3)
rez(j, 5) = y(i, 4)
rez(j, 6) = y(i, 5)
rez(j, 7) = y(i, 6)
rez(j, 9) = y(i, 7)
rez(j, 10) = y(i, 8)
rez(j, 11) = y(i, 9)
rez(j, 12) = y(i, 10)
rez(j, 13) = y(i, 11)
rez(j, 14) = y(i, 12)
rez(j, 21) = y(i, 19)
rez(j, 22) = y(i, 20)
End If
End If
Next i
End With
If j > 0 Then Sheets("Sheet2").Cells(lr, 1).Resize(j, 24).Value = rez()

End Sub
[/vba]
Using this wont solve it either;
[vba]
Range("A2").Select
ActiveSheet.Range("$A$1:$X$22").RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7 _
, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24), Header:=xlYes
[/vba]

[Kenneth Hobs]

IF you post an example file, it would be easier to help you. What determines the duplicate, the value in column A or columns A-X?

[deedii]

Attached is the file. when you re-run the macro its duplicate the existing data. It should cut the data from Sheet1 with "transfer" and move it to Sheet2 and the status should become "transfered" in Sheet2.

[mohanvijay]

try this

[vba]

Sub copy_2()
Dim i As Long
Dim Last_Rw As Long, Rw_Ct As Long
Dim WS_Pas As Worksheet
Dim T_Str As String
Set WS_Pas = Sheets("Sheet2")
Rw_Ct = WS_Pas.Cells(Rows.Count, 1).End(xlUp).Row + 1
T_Str = ""
With Sheets("Sheet1")

Last_Rw = .Cells(Rows.Count, 1).End(xlUp).Row

For i = 2 To Last_Rw

If .Cells(i, "l").Value = "transfer" Then

WS_Pas.Cells(Rw_Ct, 1).Value = .Cells(i, "A").Value
WS_Pas.Cells(Rw_Ct, 3).Value = .Cells(i, "B").Value
WS_Pas.Cells(Rw_Ct, 4).Value = .Cells(i, "C").Value
WS_Pas.Cells(Rw_Ct, 5).Value = .Cells(i, "D").Value
WS_Pas.Cells(Rw_Ct, 6).Value = .Cells(i, "E").Value
WS_Pas.Cells(Rw_Ct, 7).Value = .Cells(i, "F").Value
WS_Pas.Cells(Rw_Ct, 9).Value = .Cells(i, "G").Value
WS_Pas.Cells(Rw_Ct, 11).Value = .Cells(i, "I").Value
WS_Pas.Cells(Rw_Ct, 12).Value = .Cells(i, "J").Value
WS_Pas.Cells(Rw_Ct, 13).Value = .Cells(i, "K").Value
WS_Pas.Cells(Rw_Ct, 14).Value = "transferred"
WS_Pas.Cells(Rw_Ct, 15).Value = .Cells(i, "N").Value
WS_Pas.Cells(Rw_Ct, 20).Value = .Cells(i, "P").Value
WS_Pas.Cells(Rw_Ct, 21).Value = .Cells(i, "S").Value
WS_Pas.Cells(Rw_Ct, 22).Value = .Cells(i, "T").Value
WS_Pas.Cells(Rw_Ct, 23).Value = .Cells(i, "Q").Value

Rw_Ct = Rw_Ct + 1
T_Str = T_Str & "A" & i & ","

End If
Next i

If T_Str <> "" Then
T_Str = Left(T_Str, Len(T_Str) - 1)
.Range(T_Str).EntireRow.Delete
End If

End With

Set WS_Pas = Nothing
End Sub

[/vba]

[deedii]

Works like a charm. Thanks. mwuah.
Solved!@