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

 

[blthlt]

Bump

 

[NdNoviceHlp]

I'm on the fence re. whether this should have been a new thread. HTH. Dave

Option Explicit
Private Sub SortUnique()
Dim Cnt As Integer, Cnt4 As Integer, Cnt5 As Integer
Dim Lastrow As Integer, sht As Worksheet
'sorts unique A2 to A(lastrow) for all worksheets
'puts unique in B2 to B(whatever) for all worksheets
Cnt = 1
'data in A
For Each sht In ThisWorkbook.Sheets
With sht
Lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
'sort unique entries to B
For Cnt4 = Lastrow To 2 Step -1
For Cnt5 = (Cnt4 - 1) To 2 Step -1
If .Range("A" & Cnt5).Value = .Range("A" & Cnt4).Value Then
GoTo bart
End If
Next Cnt5
Cnt = Cnt + 1
.Range("B" & Cnt).Value = .Range("A" & Cnt4).Value
bart:
Next Cnt4
End With
Cnt = 1
Next sht
End Sub

 

[blthlt]

I'm on the fence re. whether this should have been a new thread. HTH. Dave

Option Explicit
Private Sub SortUnique()
Dim Cnt As Integer, Cnt4 As Integer, Cnt5 As Integer
Dim Lastrow As Integer, sht As Worksheet
'sorts unique A2 to A(lastrow) for all worksheets
'puts unique in B2 to B(whatever) for all worksheets
Cnt = 1
'data in A
For Each sht In ThisWorkbook.Sheets
With sht
Lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
'sort unique entries to B
For Cnt4 = Lastrow To 2 Step -1
For Cnt5 = (Cnt4 - 1) To 2 Step -1
If .Range("A" & Cnt5).Value = .Range("A" & Cnt4).Value Then
GoTo bart
End If
Next Cnt5
Cnt = Cnt + 1
.Range("B" & Cnt).Value = .Range("A" & Cnt4).Value
bart:
Next Cnt4
End With
Cnt = 1
Next sht
End Sub

Thank you very much, quick question.. if I wanted the unique values searched in cells F2:F23 in all pages and output in column B on a sheet named "output_sheet" how can I do that. I tried to change it but couldnt figure that out. Thanks.

 

[NdNoviceHlp]

U may have crossed the fence with the additional request. Anyways, this is untested. Good luck. Dave

Option Explicit
Private Sub SortUnique()
Dim Cnt As Integer, Cnt4 As Integer, Cnt5 As Integer
Dim sht As Worksheet
'sorts unique f2 to f23 for all worksheets
'puts unique in B2 to B(whatever) in sheet "output_sheet"
Cnt = 1
'data in A
For Each sht In ThisWorkbook.Sheets
If sht.Name <> "output_sheet" Then
With sht
'sort unique entries to B
For Cnt4 = 23 To 2 Step -1
For Cnt5 = (Cnt4 - 1) To 2 Step -1
If .Range("F" & Cnt5).Value = .Range("F" & Cnt4).Value Then
GoTo bart
End If
Next Cnt5
Cnt = Cnt + 1
Sheets("output_sheet").Range("B" & Cnt).Value = .Range("F" & Cnt4).Value
bart:
Next Cnt4
End With
End If
Next sht
End Sub

 

[blthlt]

This works great! Thank you, one more question; it's adding the first blank it comes to as a unique value... how do i stop that. Any more questions and I will start a new thread.

 

[NdNoviceHlp]

U didn't mention the blank cell thing before... and as I said, untested code. Good point though... don't search blank cells for results seems much more efficient. The drift on this tread is becoming continental, so maybe this is it. HTH. Dave

Option Explicit
Private Sub SortUnique()
Dim Cnt As Integer, Cnt4 As Integer, Cnt5 As Integer
Dim sht As Worksheet
'sorts unique f2 to f23 for all worksheets
'puts unique in B2 to B(whatever) in sheet "output_sheet"
Cnt = 1
'data in A
For Each sht In ThisWorkbook.Sheets
If sht.Name <> "output_sheet" Then
With sht
'sort unique entries to B
For Cnt4 = 23 To 2 Step -1
'exclude blank cells in the search
If .Range("F" & Cnt4).Value <> vbNullString Then
For Cnt5 = (Cnt4 - 1) To 2 Step -1
If .Range("F" & Cnt5).Value = .Range("F" & Cnt4).Value Then
GoTo bart
End If
Next Cnt5
Cnt = Cnt + 1
Sheets("output_sheet").Range("B" & Cnt).Value = .Range("F" & Cnt4).Value
bart
End If
Next Cnt4
End With
End If
Next sht
End Sub

 

[NdNoviceHlp]

hmmm... for sum reason the bart was missing the ":" and I missed the edit timer...grrrr

Option Explicit
Private Sub SortUnique()
Dim Cnt As Integer, Cnt4 As Integer, Cnt5 As Integer
Dim sht As Worksheet
'sorts unique f2 to f23 for all worksheets
'puts unique in B2 to B(whatever) in sheet "output_sheet"
Cnt = 1
'data in A
For Each sht In ThisWorkbook.Sheets
If sht.Name <> "output_sheet" Then
With sht
'sort unique entries to B
For Cnt4 = 23 To 2 Step -1
'exclude blank cells in the search
If .Range("F" & Cnt4).Value <> vbNullString Then
For Cnt5 = (Cnt4 - 1) To 2 Step -1
If .Range("F" & Cnt5).Value = .Range("F" & Cnt4).Value Then
GoTo bart
End If
Next Cnt5
Cnt = Cnt + 1
Sheets("output_sheet").Range("B" & Cnt).Value = .Range("F" & Cnt4).Value
bart:
End If
Next Cnt4
End With
End If
Next sht
End Sub

 

[jonattempt_cell]

How would you do this but copy the unique values when the values in the left column would disappear. Actually I'm in a situation where any number of values can appear and they will all be unique but they won't be there all the time. Hence I need to use the formula in this thread to pull the unique values as they appear and put them to the lastempy row in the right table and not copy them.

 

[NdNoviceHlp]

Maybe have someone U know read your post and see if they can understand it... I don't. The code posted extracts unique values from a known list and places them elsewhere. The code does not copy anything. If all values are unique then there's no point using this code. I really don't understand the part about how the values won't be there all the time? U need to also indicate where the input data is and where U want the output to go. HTH. Dave

 

[jonattempt_cell]

Maybe have someone U know read your post and see if they can understand it... I don't. The code posted extracts unique values from a known list and places them elsewhere. The code does not copy anything. If all values are unique then there's no point using this code. I really don't understand the part about how the values won't be there all the time? U need to also indicate where the input data is and where U want the output to go. HTH. Dave

thanks Dave see my post here : http://www.mrexcel.com/forum/excel-...ue-values-column-they-appear.html#post4098654