Comibine multiple lists, creating a unique list on a seperate worksheet/workbook, using VBA.

[Hannah24]

Hi,

I am a complete beginner at VBA.

I have a spreadsheet containing 19 columns (lists), which I need to combine into one unique list (in either a separate column in the same Sheet, or on a separate sheet, or even separate workbook. There is duplicates across all of the columns, so duplicates will also need to be removed.
The columns also have varying amounts of data.

I have been trying to amend a existing code that I have found, with no success.

Here is the code I have:

Sub MergeLists()
'Merges two lists into one without
'duplicates. The merged list is inserted
'into a new workbook and sorted.
Dim rA As Range                  'The first list
Dim rB As Range                  'The second list
Dim rC As Range                  'The third list
Dim rD As Range                  'The fourth list
Dim rE As Range                  'The firth list
Dim rF As Range                  'The sixth list
Dim rG As Range                  'The seventh list
Dim rH As Range                  'The eighth list
Dim rI As Range                  'The ninth list
Dim rJ As Range                  'The tenth list
Dim rK As Range                  'The eleventh list
Dim rL As Range                  'The twelth list
Dim rM As Range                  'The thirteenth list
Dim rN As Range                  'The fourteenth list
Dim rO As Range                  'The fiftheenth list
Dim rP As Range                  'The sixteenth list
Dim rQ As Range                  'The seventeenth list
Dim rR As Range                  'The eighteenth list
Dim rS As Range                  'The nineteenth list
Dim rT As Range                  'The twentieth list
Dim rU As Range                  'The twentyfirst list
Dim rCell As Range               'Range variable
Dim lCount As Long               'Counter
Dim colMerge As New Collection   'Collection
On Error GoTo ErrorHandle
'Switch off screen updating for speed
Application.ScreenUpdating = False
'Sets the two ranges for the lists. Here they
'have only one column, but several columns
'would make no difference.
Worksheets(1).Activate
Set rA = Range(Range("A1"), Range("A1").End(xlDown))
Worksheets(1).Activate
Set rB = Range(Range("A1"), Range("A1").End(xlDown))
Worksheets(1).Activate
Set rC = Range(Range("A1"), Range("A1").End(xlDown))
Worksheets(1).Activate
Set rD = Range(Range("A1"), Range("A1").End(xlDown))
Worksheets(1).Activate
Set rE = Range(Range("A1"), Range("A1").End(xlDown))
Worksheets(1).Activate
Set rF = Range(Range("A1"), Range("A1").End(xlDown))
Worksheets(1).Activate
Set rG = Range(Range("A1"), Range("A1").End(xlDown))
Worksheets(1).Activate
Set rH = Range(Range("A1"), Range("A1").End(xlDown))
Worksheets(1).Activate
Set rI = Range(Range("A1"), Range("A1").End(xlDown))
Worksheets(1).Activate
Set rJ = Range(Range("A1"), Range("A1").End(xlDown))
Worksheets(1).Activate
Set rK = Range(Range("A1"), Range("A1").End(xlDown))
Worksheets(1).Activate
Set rL = Range(Range("A1"), Range("A1").End(xlDown))
Worksheets(1).Activate
Set rM = Range(Range("A1"), Range("A1").End(xlDown))
Worksheets(1).Activate
Set rN = Range(Range("A1"), Range("A1").End(xlDown))
Worksheets(1).Activate
Set rO = Range(Range("A1"), Range("A1").End(xlDown))
Worksheets(1).Activate
Set rP = Range(Range("A1"), Range("A1").End(xlDown))
Worksheets(1).Activate
Set rQ = Range(Range("A1"), Range("A1").End(xlDown))
Worksheets(1).Activate
Set rR = Range(Range("A1"), Range("A1").End(xlDown))
Worksheets(1).Activate
Set rS = Range(Range("A1"), Range("A1").End(xlDown))
Worksheets(1).Activate
Set rT = Range(Range("A1"), Range("A1").End(xlDown))
Worksheets(1).Activate
Set rU = Range(Range("A1"), Range("A1").End(xlDown))
'Now we add all values to our collection. By adding
'each value as key we avoid duplicates. If a
'duplicate value is added as key, it triggers an
'error, and that is why we write:
On Error Resume Next
For Each rCell In rA
   colMerge.Add rCell.Value, rCell.Value
Next
For Each rCell In rB
   colMerge.Add rCell.Value, rCell.Value
Next
For Each rCell In rC
   colMerge.Add rCell.Value, rCell.Value
Next
For Each rCell In rD
   colMerge.Add rCell.Value, rCell.Value
Next
For Each rCell In rE
   colMerge.Add rCell.Value, rCell.Value
Next
For Each rCell In rF
   colMerge.Add rCell.Value, rCell.Value
Next
For Each rCell In rG
   colMerge.Add rCell.Value, rCell.Value
Next
For Each rCell In rH
   colMerge.Add rCell.Value, rCell.Value
Next
For Each rCell In rI
   colMerge.Add rCell.Value, rCell.Value
Next
For Each rCell In rJ
   colMerge.Add rCell.Value, rCell.Value
Next
For Each rCell In rK
   colMerge.Add rCell.Value, rCell.Value
Next
For Each rCell In rL
   colMerge.Add rCell.Value, rCell.Value
Next
For Each rCell In rM
   colMerge.Add rCell.Value, rCell.Value
Next
For Each rCell In rN
   colMerge.Add rCell.Value, rCell.Value
Next
For Each rCell In rO
   colMerge.Add rCell.Value, rCell.Value
Next
For Each rCell In rP
   colMerge.Add rCell.Value, rCell.Value
Next
For Each rCell In rQ
   colMerge.Add rCell.Value, rCell.Value
Next
For Each rCell In rR
   colMerge.Add rCell.Value, rCell.Value
Next
For Each rCell In rS
   colMerge.Add rCell.Value, rCell.Value
Next
For Each rCell In rT
   colMerge.Add rCell.Value, rCell.Value
Next
For Each rCell In rU
   colMerge.Add rCell.Value, rCell.Value
Next
On Error GoTo ErrorHandle
'Make a new workbook
Workbooks.Add
'Insert the merged list with unique values:
With colMerge
   For lCount = 1 To .Count
      Range("A1").Offset(lCount - 1).Value = .Item(lCount)
   Next
End With
'The list is defined as a range
Set rA = Range(Range("A1"), Range("A1").End(xlDown))
'and sorted ascending (default). If this code for sorting
'doesn't work with your Excel version then change it -
'e.g. by using the macro recorder.
rA.Sort Key1:=Range("A1")
BeforeExit:
Set rA = Nothing
Set rB = Nothing
Set rC = Nothing
Set rE = Nothing
Set rF = Nothing
Set rG = Nothing
Set rH = Nothing
Set rI = Nothing
Set rJ = Nothing
Set rK = Nothing
Set rL = Nothing
Set rM = Nothing
Set rN = Nothing
Set rO = Nothing
Set rP = Nothing
Set rQ = Nothing
Set rR = Nothing
Set rS = Nothing
Set rT = Nothing
Set rU = Nothing
Set rCell = Nothing
Set colMerge = Nothing
Application.ScreenUpdating = True
Exit Sub
ErrorHandle:
MsgBox Err.Description & " Procedure MergeLists"
Resume BeforeExit
End Sub

This is producing a list in a new workbook. However, it is not pulling data from all the columns.

I think there must be an issue with the amendments I have made to the code. Its is not pulling through all of the data, even for the initial column correctly, so I assume it is something to do with my data ranges.

Any help would be very much appreciated.

 

[Fluff]

Hi & welcome to MrExcel.
What columns are you lists in?
Also do the lists start in Row1 or do you have headers with the actual data starting in row2?

 

[Hannah24]

Hi,

Thank you.

My lists are in columns A, B, C, D, E, F, G, H, I ,J, K, l, M, N, O, P, Q, R, S, T, U and they all have headers.

Thanks

 

[Fluff]

Ok, how about

Sub Hannah24()
   Dim Ary As Variant
   Dim r As Long, c As Long
   Dim UsdRws As Long
   
   UsdRws = Cells.Find("*", , xlValues, , xlByRows, xlPrevious, , , False).Row
   Ary = Range("A2:U" & UsdRws).Value2
   With CreateObject("scripting.dictionary")
      .CompareMode = 1
      For c = 1 To UBound(Ary, 2)
         For r = 1 To UBound(Ary)
            If Ary(r, c) <> "" Then .Item(Ary(r, c)) = Empty
         Next r
      Next c
      Range("Z2").Resize(.Count).Value = Application.Transpose(.Keys)
   End With
End Sub

This runs on the active sheet & puts the combined list in col Z

 

[MickG]

Looks like 21 columns ??
Run on Data sheet for results on sheet2 starting "A1"

[COLOR="Navy"]Sub[/COLOR] MG11Jan00
[COLOR="Navy"]Dim[/COLOR] Ray [COLOR="Navy"]As[/COLOR] Variant, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
Ray = ActiveSheet.Cells(1).CurrentRegion.Resize(, 21)
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] n = 2 To UBound(Ray, 1)
    [COLOR="Navy"]For[/COLOR] Ac = 1 To UBound(Ray, 2)
     [COLOR="Navy"]If[/COLOR] Not .exists(Ray(n, Ac)) [COLOR="Navy"]Then[/COLOR]
      .Add Ray(n, Ac), Nothing
     [COLOR="Navy"]End[/COLOR] If
     [COLOR="Navy"]Next[/COLOR] Ac
[COLOR="Navy"]Next[/COLOR] n
Sheets("Sheet2").Range("A1").Resize(.Count).Value = Application.Transpose(.Keys)
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick