Get results onto spreadsheet instead of listbox

Brigite,

I created a little piece of code that works basically the same, but lets you choose where you want to put the final list, i hope it works for you... to use it, select the different ranges that you want to "unify - no dupes" using Control, in order to get something like A1:A200,B4:B40,D10:D20
and in the destination, select top left cell where you want the list.

Sub UnifyRanges()
'Can handle different areas. Select each area WITH heading.
'Works with AdvancedFilter, therefor, works with the same principles.
'Made by Juan Pablo González
Dim FiltRange As Range
Dim AnsRange As Variant
Dim MsgText As String
Dim AnsText As String
Dim ColumnAreas() As Integer
Dim i As Integer
Dim j As Integer
Dim Sh As Worksheet
MsgText = "Please select the ranges you want to unify."
AnsText = "Select the destination cell"
Set FiltRange = Application.InputBox(MsgText, Type:=8)
If IsObject(FiltRange) = False Then Exit Sub
Set AnsRange = Application.InputBox(AnsText, Type:=8)
If IsObject(AnsRange) = False Then Exit Sub
Select Case FiltRange.Areas.Count
Case 1
FiltRange.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=AnsRange.Range("A1"), Unique:=True
Case Else
ReDim ColumnAreas(FiltRange.Areas.Count)
For i = 1 To FiltRange.Areas.Count
ColumnAreas(i) = FiltRange.Areas(i).Columns.Count
Next i
For i = 1 To UBound(ColumnAreas) - 1
For j = i + 1 To UBound(ColumnAreas)
If ColumnAreas(i) <> ColumnAreas(j) Then
MsgBox "The Areas should have the same number of columns", vbCritical
Exit Sub
End If
Next j
Next i
Application.ScreenUpdating = False
Set Sh = Sheets.Add
With FiltRange
.Areas(1).Range("A1").Copy Destination:=Sh.Range("A1")
For i = 1 To .Areas.Count
.Areas(i).Range("A2", .Cells(.Areas(i).Rows.Count, .Areas(i).Columns.Count)).Copy Destination:=Sh.Range("A65536").End(xlUp).Offset(1)
Next i
End With
Sh.Range("A1", [A65536].End(xlUp)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=AnsRange.Range("A1"), Unique:=True
Application.DisplayAlerts = False
Sh.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Select

End Sub

Juan Pablo

Thanks Juan,

The code you provided works well. One problem and one question....

When I have a range that has the same number in the first two or more rows, (A1 = 2, A2 = 2, A3 = 2, A4 = 5, etc.) the number appears twice in the final list.

How can I modify the code so that I have a defined range (A1:T1000) in the code, but each column may not have a value in each cell of the defined range. In your current code, if I select the entire range (instead of using control) the entire range is copied to the defined destination exactly as original. Hope that is clear.

Again, thanks for any help.

--Brigite

The macro works with Advanced Filter, therefor, it assumes column headings, that's why you are getting number 2 twice.

Now, your second question, try this one, it should work as long as the entire selection (A1:T1000) is not more than 65536 cells (Your selection is 20 columns x 1.000 rows = 20.000 cells)

Sub Nuevo()
Dim FiltRange As Range
Dim AnsRange As Variant
Dim MsgText As String
Dim AnsText As String
Dim i As Integer
Dim Sh As Worksheet
MsgText = "Please select the ranges you want to unify."
AnsText = "Select the destination cell"
Set FiltRange = Application.InputBox(MsgText, Type:=8)
If IsObject(FiltRange) = False Then Exit Sub
Set AnsRange = Application.InputBox(AnsText, Type:=8)
If IsObject(AnsRange) = False Then Exit Sub
Application.ScreenUpdating = False
Set Sh = Sheets.Add
With FiltRange
For i = 1 To .Columns.Count
.Range(.Cells(1, i), .Cells(65536, i).End(xlUp)).Copy Sh.[A65536].End(xlUp).Offset(1)
Next i
Sh.Range("A1", [A65536].End(xlUp)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=AnsRange.Range("A1"), Unique:=True
Application.DisplayAlerts = False
Sh.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End With
End Sub

Juan Pablo

Juan,

Thanks!!! Works great!!! The macro works with Advanced Filter, therefor, it assumes column headings, that's why you are getting number 2 twice. Now, your second question, try this one, it should work as long as the entire selection (A1:T1000) is not more than 65536 cells (Your selection is 20 columns x 1.000 rows = 20.000 cells) Sub Nuevo()