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/me...1172/#post5326

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