Option Explicit
Option Base 1
Sub MergeArt()
Dim arr As Variant
Dim ws As Integer
Dim rcnt As Long
Dim alen As Long
Dim r As Long
'Some optimization
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
ReDim arr(1)
alen = 0
For ws = 1 To 3
rcnt = Sheets(ws).UsedRange.Rows.Count - 1
ReDim Preserve arr(rcnt + alen)
For r = 1 To rcnt
arr(r + alen) = Sheets(ws).Cells(r + 1, 1).Value
Next
alen = alen + rcnt
Next
SortArray arr
RemoveDuplicates arr
For r = 1 To UBound(arr)
Sheets(4).Cells(r + 1, 1).Value = arr(r)
Next
Sheets(4).Select
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox "Done"
End Sub
Private Sub SortArray(ByRef a As Variant)
Dim i As Long, j As Long
Dim t As Variant
'standard bubble sort loops
For i = LBound(a) To UBound(a) - 1
For j = i + 1 To UBound(a)
If a(i) > a(j) Then 'change to < for descending order
t = a(i)
a(i) = a(j)
a(j) = t
End If
Next j
Next i
End Sub
Private Sub RemoveDuplicates(ByRef a As Variant)
Dim i As Long, j As Long
j = 1
Dim t() As Variant
ReDim t(1)
t(1) = a(1)
For i = LBound(a) To UBound(a) - 1
If a(i) <> a(i + 1) Then
j = j + 1
ReDim Preserve t(j)
t(j) = a(i + 1)
End If
Next i
ReDim a(j)
a = t
End Sub
|
