PDA

View Full Version : Solved: Data Duplication Problem



deedii
12-28-2011, 05:44 PM
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?


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

Using this wont solve it either;

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

Kenneth Hobs
12-29-2011, 09:49 AM
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
12-29-2011, 06:35 PM
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
12-29-2011, 09:14 PM
try this



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

deedii
01-01-2012, 06:16 PM
Works like a charm. Thanks. mwuah. :)
Solved!@