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:
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.
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:
Code:
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.
Last edited by a moderator: