Copy duplicates to new sheets with dynamic column sources VBA

[ymk10]

Hi all

I am very new to vba and i am trying to find a way on how to find duplicate data in any column range that you can specify and duplicates found should be copied into a new worksheet.

An example of what i want is lets say i have data from column A to E, when i run the macro a dialog box should open that prompts me to highlight the desired column range and from there checks for duplicates and copies this to a new worksheet.

Lets say in my column A i have the following data in the cells A1-A5:

A1 1 A2 1 A3 2 A4 3 A5 4

the number 1 is duplicated, so in the new sheet i expect to see the 1s in A1 and A2 copied in a new sheet in their separate respective cells A1 and A2. Same thing applies if i highlight multiple column data such as A to E etc.

I know probably this entirely possible through excel formula but i would really appreciate a solution in vba which works fast enough as i have thousands of rows of information.

Thanks in advance.

 

[ymk10]

I have tried using the code below which sort of works but it is always creating an additional row with some blank cells shown in the picture below. The green highlighted rows are the correct duplicates detected and the red highlighted is the additional row that appears with some blank cells. Can anyone fix the code so that the additional rows do not appear?

Sub ertert()
Dim x, y(), i&, j&, t(), bu As Boolean
x = Application.InputBox("Select the Range", "RANGE SELECTION", Type:=8)
ReDim y(1 To UBound(x), 1 To UBound(x, 2))
With CreateObject("Scripting.Dictionary")
 .CompareMode = 0
 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


If bu Then Sheets.Add.Range("A2").Resize(i - 1, j - 1).Value = y()
End Sub