Consolidate different ranges with no dups - For Eric
Posted by Juan Pablo on October 07, 2001 2:57 PM
Have a look at this macro, Have a look at this macro. It enableds you to input a number of ranges in order to get one list of unique enties without duplication. It ASSUMES ranges have headings.
Option Explicit
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