Extract unique values from one column using VBA

[boldcode]

Hi,

I want to extract all the unique values from column A starting with A2 to the last cell of column A that has a value and copy those values into cell B2 all the way down to whatever the last cell of column B is.

I have row titles in cells A1 and B1.

Example:

Data Before Macro:

	Column A	Column B
Row 1	All Codes	Distinct Codes
Row 2	456
Row 3	456
Row 4	678
Row 5	678
Row 6	890
Row 7	543
Row 8	543
Row 9	234
Row 10	213
Row 11	905
Row 12	905

<colgroup><col style="mso-width-source:userset;mso-width-alt:4096;width:84pt" width="112"> <col style="mso-width-source:userset;mso-width-alt:5997;width:123pt" width="164"> <col style="mso-width-source:userset;mso-width-alt:4973;width:102pt" width="136"> </colgroup><tbody>
</tbody>

Data After Macro:

	Column A	Column B
Row 1	All Codes	Distinct Codes
Row 2	456	456
Row 3	456	678
Row 4	678	890
Row 5	678	543
Row 6	890	234
Row 7	543	213
Row 8	543	905
Row 9	234
Row 10	213
Row 11	905
Row 12	905

<colgroup><col style="mso-width-source:userset;mso-width-alt:4864;width:100pt" width="133"> <col style="mso-width-source:userset;mso-width-alt:4571;width:94pt" width="125"> <col style="mso-width-source:userset;mso-width-alt:5120;width:105pt" width="140"> </colgroup><tbody>
</tbody>

Thanks,

BC

 

[SerhatC]

Hi,

I have a data below and i want to extract unique values to the side of each report. For example, I want to have a code which will work when I run the macro in the cells B3, D3, F3, H3, J3 and so on. I am using excel 2010. thanks!

Report1			Report2			Report3			Report4			Report5			Report6
Full	Unique		Full	Unique		Full	Unique		Full	Unique		Full	Unique		Full	Unique
7			9			5			2			6			1
1			2			10			2			6			3
5			3			9			3			4			10
1			6			6			5			5			2
2			2			6			1			6			1
1			3			2			10			5			10
5			4			9			6			2			9
1			10			2			5			9			10
3			5			9			10			1			9
2			2			7			4			1			3
9			4			8			10			8			7
1			3			1			6			1			7
5			10			6			9			7			7
9			5			7			7			2			6

<colgroup><col span="2"><col><col span="2"><col><col span="2"><col><col span="2"><col><col span="2"><col><col span="2"></colgroup><tbody>
</tbody>

 

[hiker95]

SerhatC,

If I understand your instructions, and, flat text display, then here is a macro solution for you to consider that re-uses one array in memory, and, it will adjust to the varying number of raw data rows, and, columns in the raw data worksheet.

You can change the raw data worksheet name in the macro.

Sample raw data, and, results:

Excel 2007
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R
1	Report1			Report2			Report3			Report4			Report5			Report6
2	Full	Unique		Full	Unique		Full	Unique		Full	Unique		Full	Unique		Full	Unique
3	7	7		9	9		5	5		2	2		6	6		1	1
4	1	1		2	2		10	10		2	3		6	4		3	3
5	5	5		3	3		9	9		3	5		4	5		10	10
6	1	2		6	6		6	6		5	1		5	2		2	2
7	2	3		2	4		6	2		1	10		6	9		1	9
8	1	9		3	10		2	7		10	6		5	1		10	7
9	5			4	5		9	8		6	4		2	8		9	6
10	1			10			2	1		5	9		9	7		10
11	3			5			9			10	7		1			9
12	2			2			7			4			1			3
13	9			4			8			10			8			7
14	1			3			1			6			1			7
15	5			10			6			9			7			7
16	9			5			7			7			2			6
17
18
Sheet1

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

1. Copy the below code
2. Open your NEW workbook
3. Press the keys ALT + F11 to open the Visual Basic Editor
4. Press the keys ALT + I to activate the Insert menu
5. Press M to insert a Standard Module
6. Where the cursor is flashing, paste the code
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. To run the macro from Excel press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.

Sub ExtractUniquesMulti()
' hiker95, 12/15/2015, ME749576
Dim d As Object, o As Variant, i As Long
Dim lr As Long, lc As Long, c As Long
Application.ScreenUpdating = False

With Sheets("Sheet1")   '<-- you can change the sheet name here

  lc = .Cells(2, Columns.Count).End(xlToLeft).Column
  For c = 1 To lc - 1 Step 3
    Set d = CreateObject("Scripting.Dictionary")
    lr = .Cells(Rows.Count, 1).End(xlUp).Row
    o = .Range(.Cells(3, c), .Cells(lr, c))
    For i = 1 To UBound(o, 1)
      d(o(i, 1)) = 1
    Next i
    .Cells(3, c + 1).Resize(d.Count) = Application.Transpose(d.keys)
    Set d = Nothing
    Erase o
  Next c
End With
Application.ScreenUpdating = True
End Sub

Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm, and, answer the "do you want to enable macros" question as "yes" or "OK" (depending on the button label for your version of Excel) the next time you open your workbook.

Then run the ExtractUniquesMulti macro.

 

[NikolaJovanovic]

I'm using the hiker95 code with minor customization:

[I]Sub GetUniques()
' hiker95, 07/26/2012
' [URL="http://www.mrexcel.com/forum/showthread.php?649576-Extract-unique-values-from-one-column-using-VBA"]Extract unique values from one column using VBA[/URL]
Dim d As Object, c As Variant, i As Long, lr As Long
Set d = CreateObject("Scripting.Dictionary")
lr = Cells(Rows.Count, 1).End(xlUp).Row
c = Range("A2:A" & lr)
For i = 1 To UBound(c, 1)
  d(c(i, 1)) = 1
Next i
'Adds a New Sheet
Worksheets.Add
ActiveSheet.Name = "UNIQUE VALUES"
Range("a1").Activate
Range("a1").Resize(d.Count) = Application.Transpose(d.keys)
End Sub[/I]

The trouble is that I don't want blank cells to show as a result.
Like below the list goes on and it has spaces in between.
What modifications of the code could be done to extract unique data one after another?
Thanks.

	A
1	Creditor
2	KN00104
3	KN00104
4	KN00104
5	KN00104
6	KN00104
7	KN00104
8	KN00104
9	KN00104
10	KN00104
11
12
13
14	KN01341
15	KN01341
16	KN01341
17	KN01341
18	KN01341
19	KN01341
20	KN01341
21
22
23
24	KN00402
25	KN00402
26	KN00402
27	KN00402
28	KN00402
29	KN00402

<tbody>
</tbody>

KN AGING​

 

[Trebor76]

Try this slight modification on hiker95's nifty code:

Option Explicit
Sub GetUniques()
' hiker95, 07/26/2012
' Extract unique values from one column using VBA  Trebor76, 02/08/2016 now excluding blanks
Dim d As Object, c As Variant, i As Long, lr As Long
Set d = CreateObject("Scripting.Dictionary")
lr = Cells(Rows.Count, 1).End(xlUp).Row
c = Range("A2:A" & lr)
For i = 1 To UBound(c, 1)
    If Len(c(i, 1)) > 0 Then
        d(c(i, 1)) = 1
    End If
Next i
'Adds a New Sheet
Worksheets.Add
ActiveSheet.Name = "UNIQUE VALUES"
Range("a1").Activate
Range("a1").Resize(d.Count) = Application.Transpose(d.keys)
End Sub

 

[NikolaJovanovic]

Try this slight modification on hiker95's nifty code:

Option Explicit
Sub GetUniques()
' hiker95, 07/26/2012
' Extract unique values from one column using VBA  Trebor76, 02/08/2016 now excluding blanks
Dim d As Object, c As Variant, i As Long, lr As Long
Set d = CreateObject("Scripting.Dictionary")
lr = Cells(Rows.Count, 1).End(xlUp).Row
c = Range("A2:A" & lr)
For i = 1 To UBound(c, 1)
    If Len(c(i, 1)) > 0 Then
        d(c(i, 1)) = 1
    End If
Next i
'Adds a New Sheet
Worksheets.Add
ActiveSheet.Name = "UNIQUE VALUES"
Range("a1").Activate
Range("a1").Resize(d.Count) = Application.Transpose(d.keys)
End Sub

If Len(c(i, 1)) > 0 Then

That was missing. Great.

Thanks a lot.

 

[pvr928]

Hi there

I love good VBA as much as the next person, but I'll admit I'm no coding guru.

What about a simpler approach - ALT - A - M, or a modification of:

ActiveSheet.Range("$A$1:$A$42").RemoveDuplicates Columns:=1, Header:=xlNo

Of course, then post the column without duplicates where you want it.

Cheers

pvr928

 

[Trebor76]

Hi Nikola,

You're welcome I'm glad we were able to help.

Hi pvr928,

That will still leave a blank row in the end result which the OP was trying to avoid.

Regards,

Robert

 

[hiker95]

Trebor76,

Thanks for updating the macro code for NikolaJovanovic.

 

[Trebor76]

Hi hiker95,

You're welcome but you're the one who should be thanked for posting the code originally!! Great job

Robert

 

[hiker95]

Trebor76,

Thank you again.