Find And Move Duplicate Values From One Sheet To Another Worksheet

[maximbebi]

Hello,Please help me

I have a file with many values, distributed across multiple columns.

From sheet1 i want to find and move all the duplicate values in the sheet 2

and I need a macro,a code macro to work at the level of the sheets, Sheet1-Sheet2

I want to move cut/paste all values duplicates 2 times 3 times or how many times is found
from sheet1, in sheet2 the results to be made in columns A and B

in sheet 1 to remain single value, only the values themselves which didn't pair
I mean if a value is 2 times
to move the original value
but and double found

Thank you

[Admin]

Hi

Welcome to board !!

Try this


Option Explicit

Sub kTest()

Dim k, q, t, i As Long, c As Long

k = Sheet1.Range("a2:a" & Sheet1.Range("a" & Sheet1.Rows.Count).End(3).Row).Resize(, 13).Value2

With CreateObject("scripting.dictionary")
.comparemode = 1
For c = 1 To UBound(k, 2)
For i = 1 To UBound(k, 1)
If LenB(k(i, c)) Then
t = .Item(k(i, c))
If Not IsEmpty(t) Then
t = Split(t, "_")(1)
.Item(k(i, c)) = k(i, c) & "_" & Val(t) + 1
Else
.Item(k(i, c)) = k(i, c) & "_" & 1
End If
End If
Next
Next
k = .items
End With
q = Filter(k, "_1", True)
Sheet1.UsedRange.ClearContents
Sheet1.Range("a2").Resize(UBound(q) + 1) = Application.Transpose(q)
Sheet1.Range("a2").Resize(UBound(q) + 1).TextToColumns Sheet1.Range("a2"), 1, other:=1, otherchar:="_"
q = Filter(k, "_1", False)
Sheet2.UsedRange.ClearContents
Sheet2.Range("a2").Resize(UBound(q) + 1) = Application.Transpose(q)
Sheet2.Range("a2").Resize(UBound(q) + 1).TextToColumns Sheet2.Range("a2"), 1, other:=1, otherchar:="_"

End Sub

[maximbebi]

is good
Thanks
I have a code from a friend, you can change it as the results to be placed on columns a and b on sheet2



Sub ertert()
Dim x, y(), i&, j&, t(), bu As Boolean
x = Sheets("Foaie1").Range("A2").CurrentRegion.Value
Redim y(1 To UBound(x), 1 To UBound(x, 2))
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
For i = 1 To UBound(x)
For j = 1 To UBound(x, 2)
If Len(x(i, j)) Then
If .Exists(x(i, j)) Then
t = .Item(x(i, j)): bu = True
y(t(0), t(1)) = x(i, j): y(i, j) = x(i, j)
x(i, j) = "": x(t(0), t(1)) = ""
Else
.Item(x(i, j)) = Array(i, j)
End If
End If
Next j
Next i
End With
Sheets("Foaie1").Range("A2").Resize(i - 1, j - 1).Value = x
If bu Then Sheets("Foaie2").Range("A2").Resize(i - 1, j - 1).Value = y()
End Sub




Thanks

[Admin]

Hi

I found you posted this question on several forums.

Please read http://www.excelfox.com/forum/f25/message-to-cross-posters-1172/#post5326

Also my code put the data in Col A & B on Sheet 2, didn't it ?