Copy duplicates to new sheets with dynamic column sources VBA

ymk10

New Member
Joined
Jan 6, 2021
Messages
2
Office Version
  1. 2016
Platform
  1. Windows
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.
 

Some videos you may like

Excel Facts

Convert text numbers to real numbers
Select a column containing text numbers. Press Alt+D E F to quickly convert text to numbers. Faster than "Convert to Number"

ymk10

New Member
Joined
Jan 6, 2021
Messages
2
Office Version
  1. 2016
Platform
  1. Windows
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?

VBA Code:
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


1.png
 

Watch MrExcel Video

Forum statistics

Threads
1,127,808
Messages
5,627,010
Members
416,214
Latest member
boston814

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top