I am surprised at how slow this bubble sort algorithm is using VBA. So my question is am I doing something wrong/inefficient, or is this just the best VBA and bubble sort will do? For instance, could using VARIANTs, too many variables, etc. be slowing performance substantially. I know Bubble Sort is not particularly fast, but I didn't think it would be this slow.
Algorithm inputs: 2D array and either one or two columns to sort by, each asc or desc.
I don't necessarily need lightning fast, but 30 seconds for 5,000 rows is completely unacceptable
Option Explicit
Sub sortA()
Dim start_time, end_time
start_time = Now()
Dim ThisArray() As Variant
Dim sheet As Worksheet
Dim a, b As Integer
Dim rows, cols As Integer
Set sheet = ArraySheet
rows = 5000
cols = 3
ReDim ThisArray(0 To cols - 1, 0 To rows - 1)
For a = 1 To rows
For b = 1 To cols
ThisArray(b - 1, a - 1) = ArraySheet.Cells(a, b)
Next b
Next a
Call BubbleSort(ThisArray, 0, False, 2, True)
end_time = Now()
MsgBox (DateDiff("s", start_time, end_time))
End Sub
'Array Must Be: Array(Column,Row)
Sub BubbleSort(ThisArray As Variant, SortColumn1 As Integer, Asc1 As Boolean, Optional SortColumn2 As Integer = -1, Optional Asc2 As Boolean)
Dim FirstRow As Integer
Dim LastRow As Integer
Dim FirstCol As Integer
Dim LastCol As Integer
Dim lTemp As Variant
Dim i, j, k As Integer
Dim a1, a2, b1, b2 As Variant
Dim CompareResult As Boolean
FirstRow = LBound(ThisArray, 2)
LastRow = UBound(ThisArray, 2)
FirstCol = LBound(ThisArray, 1)
LastCol = UBound(ThisArray, 1)
For i = FirstRow To LastRow
For j = i + 1 To LastRow
If SortColumn2 = -1 Then 'If there is only one column to sort by
a1 = ThisArray(SortColumn1, i)
a2 = ThisArray(SortColumn1, j)
If Asc1 = True Then
CompareResult = compareOne(a1, a2)
Else
CompareResult = compareOne(a2, a1)
End If
Else 'If there are two columns to sort by
a1 = ThisArray(SortColumn1, i)
a2 = ThisArray(SortColumn1, j)
b1 = ThisArray(SortColumn2, i)
b2 = ThisArray(SortColumn2, j)
If Asc1 = True Then
If Asc2 = True Then
CompareResult = compareTwo(a1, a2, b1, b2)
Else
CompareResult = compareTwo(a1, a2, b2, b1)
End If
Else
If Asc2 = True Then
CompareResult = compareTwo(a2, a1, b1, b2)
Else
CompareResult = compareTwo(a2, a1, b2, b1)
End If
End If
End If
If CompareResult = True Then ' If compare result returns true, Flip rows
For k = FirstCol To LastCol
lTemp = ThisArray(k, j)
ThisArray(k, j) = ThisArray(k, i)
ThisArray(k, i) = lTemp
Next k
End If
Next j
Next i
End Sub
Function compareOne(FirstCompare1 As Variant, FirstCompare2 As Variant) As Boolean
If FirstCompare1 > FirstCompare2 Then
compareOne = True
Else
compareOne = False
End If
End Function
Function compareTwo(FirstCompare1 As Variant, FirstCompare2 As Variant, SecondCompare1 As Variant, SecondCompare2 As Variant) As Boolean
If FirstCompare1 > FirstCompare2 Then
compareTwo = True
ElseIf FirstCompare1 = FirstCompare2 And SecondCompare1 > SecondCompare2 Then
compareTwo = True
Else
compareTwo = False
End If
End Function
Thanks a ton for any help or advice!!
Edit: I decided to used QuickSort instead. See post below for the code if interested.
First of all: don't use bubble sort on 5000 rows! It'll take 5000^2/2 iterations, i.e. 12.5B iterations! Better use a decent QuickSort algorithm. At the bottom of this post you'll find one that you could use as a starting point. It only compares column 1. On my system, the sorting of took 0.01s (instead of the 4s after optimization of bubble sort).
Now, for the challenge, check out the below code. It runs at ~30% of the original run time - and at the same time reduces the lines of code significantly.
The main levers were:
Use Double instead of Variant for the main array (Variant always comes with some overhead in terms of memory management)
Reduce the number of calls/handovers of variables - instead of using your subs CompareOne and CompareTwo, I inlined the code and optimized it. Also, I accessed the values directly without assigning them to a temp variable
Just populating the array took 10% of the total time. Instead, I bulk assigned the array (had to switch rows & columns for that) and then casted it to a double array
The speed could be further optimized by having two separate loops - one for one column and one for two columns. This reduces run time by ~10%, but bloats the code so left it out.
Option Explicit
Sub sortA()
Dim start_time As Double
Dim varArray As Variant, dblArray() As Double
Dim a, b As Long
Const rows As Long = 5000
Const cols As Long = 3
start_time = Timer
'Copy everything to array of type variant
varArray = ArraySheet.Range("A1").Resize(rows, cols).Cells
'Cast variant to double
ReDim dblArray(1 To rows, 1 To cols)
For a = 1 To rows
For b = 1 To cols
dblArray(a, b) = varArray(a, b)
Next b
Next a
BubbleSort dblArray, 1, False, 2, True
MsgBox Format(Timer - start_time, "0.00")
End Sub
'Array Must Be: Array(Column,Row)
Sub BubbleSort(ThisArray() As Double, SortColumn1 As Long, Asc1 As Boolean, Optional SortColumn2 As Long = -1, Optional Asc2 As Boolean)
Dim LastRow As Long
Dim FirstCol As Long
Dim LastCol As Long
Dim lTemp As Double
Dim i, j, k As Long
Dim CompareResult As Boolean
LastRow = UBound(ThisArray, 1)
FirstCol = LBound(ThisArray, 2)
LastCol = UBound(ThisArray, 2)
For i = LBound(ThisArray, 1) To LastRow
For j = i + 1 To LastRow
If SortColumn2 = -1 Then 'If there is only one column to sort by
CompareResult = ThisArray(i, SortColumn1) <= ThisArray(j, SortColumn1)
If Asc1 Then CompareResult = Not CompareResult
Else 'If there are two columns to sort by
Select Case ThisArray(i, SortColumn1)
Case Is < ThisArray(j, SortColumn1): CompareResult = Not Asc1
Case Is > ThisArray(j, SortColumn1): CompareResult = Asc1
Case Else
CompareResult = ThisArray(i, SortColumn2) <= ThisArray(j, SortColumn2)
If Asc2 Then CompareResult = Not CompareResult
End Select
End If
If CompareResult Then ' If compare result returns true, Flip rows
For k = FirstCol To LastCol
lTemp = ThisArray(j, k)
ThisArray(j, k) = ThisArray(i, k)
ThisArray(i, k) = lTemp
Next k
End If
Next j
Next i
End Sub
Here's a QuickSort implementation:
Public Sub subQuickSort(var1 As Variant, _
Optional ByVal lngLowStart As Long = -1, _
Optional ByVal lngHighStart As Long = -1)
Dim varPivot As Variant
Dim lngLow As Long
Dim lngHigh As Long
lngLowStart = IIf(lngLowStart = -1, LBound(var1), lngLowStart)
lngHighStart = IIf(lngHighStart = -1, UBound(var1), lngHighStart)
lngLow = lngLowStart
lngHigh = lngHighStart
varPivot = var1((lngLowStart + lngHighStart) \ 2, 1)
While (lngLow <= lngHigh)
While (var1(lngLow, 1) < varPivot And lngLow < lngHighStart)
lngLow = lngLow + 1
Wend
While (varPivot < var1(lngHigh, 1) And lngHigh > lngLowStart)
lngHigh = lngHigh - 1
Wend
If (lngLow <= lngHigh) Then
subSwap var1, lngLow, lngHigh
lngLow = lngLow + 1
lngHigh = lngHigh - 1
End If
Wend
If (lngLowStart < lngHigh) Then
subQuickSort var1, lngLowStart, lngHigh
End If
If (lngLow < lngHighStart) Then
subQuickSort var1, lngLow, lngHighStart
End If
End Sub
Private Sub subSwap(var As Variant, lngItem1 As Long, lngItem2 As Long)
Dim varTemp As Variant
varTemp = var(lngItem1, 1)
var(lngItem1, 1) = var(lngItem2, 1)
var(lngItem2, 1) = varTemp
End Sub
My thoughts:
You really don't want to use an N^2 algorithm for anything that has more than 20-30 items (maximum). If you have 5000-10000 rows, starting with BubbleSort was a mistake, IMHO
VBA is unpredictable. Beyond ditching bubbleSort (just ask Barack Obama), you want to try different ways of doing things in VBA.
For example:
Replace for ... next loops with for ... each loops: the latter (paradoxically) can be faster
Try using variants versus immediately converting to primitive types and using those. It used to be the case that VBA handled Variants much faster, but YMMV.
Here is my implementation of quicksort for anyone interested. I am sure the code could be cleaned up quite a but, but here is a good start. This code sorted 10,000 rows in less then a second.
Option Explicit
' QuickSort for 2D array in form Array(cols,rows)
' Enter in 1, 2, or 3 columns to sort by, each can be either asc or desc
Public Sub QuickSortStart(ThisArray As Variant, sortColumn1 As Integer, asc1 As Boolean, Optional sortColumn2 As Integer = -1, Optional asc2 As Boolean = True, Optional sortColumn3 As Integer = -1, Optional asc3 As Boolean = True)
Dim LowerBound As Integer
Dim UpperBound As Integer
LowerBound = LBound(ThisArray, 2)
UpperBound = UBound(ThisArray, 2)
Call QuickSort(ThisArray, LowerBound, UpperBound, sortColumn1, asc1, sortColumn2, asc2, sortColumn3, asc3)
End Sub
Private Sub QuickSort(ThisArray As Variant, FirstRow As Integer, LastRow As Integer, sortColumn1 As Integer, asc1 As Boolean, sortColumn2 As Integer, asc2 As Boolean, sortColumn3 As Integer, asc3 As Boolean)
Dim pivot1 As Variant
Dim pivot2 As Variant
Dim pivot3 As Variant
Dim tmpSwap As Variant
Dim tmpFirstRow As Integer
Dim tmpLastRow As Integer
Dim FirstCol As Integer
Dim LastCol As Integer
Dim i As Integer
tmpFirstRow = FirstRow
tmpLastRow = LastRow
FirstCol = LBound(ThisArray, 1)
LastCol = UBound(ThisArray, 1)
pivot1 = ThisArray(sortColumn1, (FirstRow + LastRow) \ 2)
If sortColumn2 <> -1 Then
pivot2 = ThisArray(sortColumn2, (FirstRow + LastRow) \ 2)
End If
If sortColumn3 <> -1 Then
pivot3 = ThisArray(sortColumn3, (FirstRow + LastRow) \ 2)
End If
While (tmpFirstRow <= tmpLastRow)
While (compareFirstLoop(ThisArray, pivot1, pivot2, pivot3, tmpFirstRow, sortColumn1, asc1, sortColumn2, asc2, sortColumn3, asc3) And tmpFirstRow < LastRow)
tmpFirstRow = tmpFirstRow + 1
Wend
While (compareSecondLoop(ThisArray, pivot1, pivot2, pivot3, tmpLastRow, sortColumn1, asc1, sortColumn2, asc2, sortColumn3, asc3) And tmpLastRow > FirstRow)
tmpLastRow = tmpLastRow - 1
Wend
If (tmpFirstRow <= tmpLastRow) Then
For i = FirstCol To LastCol
tmpSwap = ThisArray(i, tmpFirstRow)
ThisArray(i, tmpFirstRow) = ThisArray(i, tmpLastRow)
ThisArray(i, tmpLastRow) = tmpSwap
Next i
tmpFirstRow = tmpFirstRow + 1
tmpLastRow = tmpLastRow - 1
End If
Wend
If (FirstRow < tmpLastRow) Then
Call QuickSort(ThisArray, FirstRow, tmpLastRow, sortColumn1, asc1, sortColumn2, asc2, sortColumn3, asc3)
End If
If (tmpFirstRow < LastRow) Then
Call QuickSort(ThisArray, tmpFirstRow, LastRow, sortColumn1, asc1, sortColumn2, asc2, sortColumn3, asc3)
End If
End Sub
Private Function compareFirstLoop(ThisArray As Variant, pivot1 As Variant, pivot2 As Variant, pivot3 As Variant, checkRow As Integer, sortColumn1 As Integer, asc1 As Boolean, sortColumn2 As Integer, asc2 As Boolean, sortColumn3 As Integer, asc3 As Boolean)
If asc1 = True And ThisArray(sortColumn1, checkRow) < pivot1 Then
compareFirstLoop = True
ElseIf asc1 = False And ThisArray(sortColumn1, checkRow) > pivot1 Then
compareFirstLoop = True
'Move to Second Column
ElseIf sortColumn2 <> -1 And ThisArray(sortColumn1, checkRow) = pivot1 Then
If asc2 = True And ThisArray(sortColumn2, checkRow) < pivot2 Then
compareFirstLoop = True
ElseIf asc2 = False And ThisArray(sortColumn2, checkRow) > pivot2 Then
compareFirstLoop = True
'Move to Third Column
ElseIf sortColumn3 <> -1 And ThisArray(sortColumn2, checkRow) = pivot2 Then
If asc3 = True And ThisArray(sortColumn3, checkRow) < pivot3 Then
compareFirstLoop = True
ElseIf asc3 = False And ThisArray(sortColumn3, checkRow) > pivot3 Then
compareFirstLoop = True
Else
compareFirstLoop = False
End If
Else
compareFirstLoop = False
End If
Else
compareFirstLoop = False
End If
End Function
Private Function compareSecondLoop(ThisArray As Variant, pivot1 As Variant, pivot2 As Variant, pivot3 As Variant, checkRow As Integer, sortColumn1 As Integer, asc1 As Boolean, sortColumn2 As Integer, asc2 As Boolean, sortColumn3 As Integer, asc3 As Boolean)
If asc1 = True And pivot1 < ThisArray(sortColumn1, checkRow) Then
compareSecondLoop = True
ElseIf asc1 = False And pivot1 > ThisArray(sortColumn1, checkRow) Then
compareSecondLoop = True
'Move to Second Column
ElseIf sortColumn2 <> -1 And ThisArray(sortColumn1, checkRow) = pivot1 Then
If asc2 = True And pivot2 < ThisArray(sortColumn2, checkRow) Then
compareSecondLoop = True
ElseIf asc2 = False And pivot2 > ThisArray(sortColumn2, checkRow) Then
compareSecondLoop = True
'Move to Third Column
ElseIf sortColumn3 <> -1 And ThisArray(sortColumn2, checkRow) = pivot2 Then
If asc3 = True And pivot3 < ThisArray(sortColumn3, checkRow) Then
compareSecondLoop = True
ElseIf asc3 = False And pivot3 > ThisArray(sortColumn3, checkRow) Then
compareSecondLoop = True
Else
compareSecondLoop = False
End If
Else
compareSecondLoop = False
End If
Else
compareSecondLoop = False
End If
End Function
I have been asked to ask this question again and in a little different context. This is the previous post:
Filtering in VBA after finding combinations
I would like to make this code possible with 100 different variables without having excel run out of memory and reducing the execution time significantly.
The problem with the code below is that if I have 100 boxes, excel will run out of memory in the line "Result(0 To 2 ^ NumFields - 2)" ( The code works for < 10 boxes)
This is my input:
3 A B C D E ...
7.7 3 1 1 1 2 ...
5.5 2 1 2 3 3 ...
This is the code:
Function stackBox()
Dim ws As Worksheet
Dim width As Long
Dim height As Long
Dim numOfBox As Long
Dim optionsA() As Variant
Dim results() As Variant
Dim str As String
Dim outputArray As Variant
Dim i As Long, j As Long
Dim currentSymbol As String
'------------------------------------new part----------------------------------------------
Dim maxHeight As Double
Dim maxWeight As Double
Dim heightarray As Variant
Dim weightarray As Variant
Dim totalHeight As Double
Dim totalWeight As Double
'------------------------------------new part----------------------------------------------
Set ws = Worksheets("Sheet1")
With ws
'clear last time's output
height = .Cells(.Rows.Count, 1).End(xlUp).row
If height > 3 Then
.Range(.Cells(4, 1), .Cells(height, 1)).ClearContents
End If
numOfBox = .Cells(1, 1).Value
width = .Cells(1, .Columns.Count).End(xlToLeft).Column
If width < 2 Then
MsgBox "Error: There's no item, please fill your item in Cell B1,C1,..."
Exit Function
End If
'------------------------------------new part----------------------------------------------
maxHeight = .Cells(2, 1).Value
maxWeight = .Cells(3, 1).Value
ReDim heightarray(1 To 1, 1 To width - 1)
ReDim weightarray(1 To 1, 1 To width - 1)
heightarray = .Range(.Cells(2, 2), .Cells(2, width)).Value
weightarray = .Range(.Cells(3, 2), .Cells(3, width)).Value
'------------------------------------new part----------------------------------------------
ReDim optionsA(0 To width - 2)
For i = 0 To width - 2
optionsA(i) = .Cells(1, i + 2).Value
Next i
GenerateCombinations optionsA, results, numOfBox
' copy the result to sheet only once
ReDim outputArray(1 To UBound(results, 1) - LBound(results, 1) + 1, 1 To 1)
Count = 0
For i = LBound(results, 1) To UBound(results, 1)
If Not IsEmpty(results(i)) Then
'rowNum = rowNum + 1
str = ""
totalHeight = 0#
totalWeight = 0#
For j = LBound(results(i), 1) To UBound(results(i), 1)
currentSymbol = results(i)(j)
str = str & currentSymbol 'results(i)(j) is the SYMBOL e.g. A, B, C
'look up box's height and weight , increment the totalHeight/totalWeight
updateParam currentSymbol, optionsA, heightarray, weightarray, totalHeight, totalWeight
Next j
If totalHeight < maxHeight And totalWeight < maxWeight Then
Count = Count + 1
outputArray(Count, 1) = str
End If
'.Cells(rowNum, 1).Value = str
End If
Next i
.Range(.Cells(4, 1), .Cells(UBound(outputArray, 1) + 3, 1)).Value = outputArray
End With
End Function
Sub updateParam(ByRef targetSymbol As String, ByRef symbolArray As Variant, ByRef heightarray As Variant, ByRef weightarray As Variant, ByRef totalHeight As Double, ByRef totalWeight As Double)
Dim i As Long
Dim index As Long
index = -1
For i = LBound(symbolArray, 1) To UBound(symbolArray, 1)
If targetSymbol = symbolArray(i) Then
index = i
Exit For
End If
Next i
If index <> -1 Then
totalHeight = totalHeight + heightarray(1, index + 1)
totalWeight = totalWeight + weightarray(1, index + 1)
End If
End Sub
Sub GenerateCombinations(ByRef AllFields() As Variant, _
ByRef Result() As Variant, ByVal numOfBox As Long)
Dim InxResultCrnt As Integer
Dim InxField As Integer
Dim InxResult As Integer
Dim i As Integer
Dim NumFields As Integer
Dim Powers() As Integer
Dim ResultCrnt() As String
NumFields = UBound(AllFields) - LBound(AllFields) + 1
ReDim Result(0 To 2 ^ NumFields - 2) ' one entry per combination
ReDim Powers(0 To NumFields - 1) ' one entry per field name
' Generate powers used for extracting bits from InxResult
For InxField = 0 To NumFields - 1
Powers(InxField) = 2 ^ InxField
Next
For InxResult = 0 To 2 ^ NumFields - 2
' Size ResultCrnt to the max number of fields per combination
' Build this loop's combination in ResultCrnt
ReDim ResultCrnt(0 To NumFields - 1)
InxResultCrnt = -1
For InxField = 0 To NumFields - 1
If ((InxResult + 1) And Powers(InxField)) <> 0 Then
' This field required in this combination
InxResultCrnt = InxResultCrnt + 1
ResultCrnt(InxResultCrnt) = AllFields(InxField)
End If
Next
If InxResultCrnt = 0 Then
Debug.Print "testing"
End If
'additional logic here
If InxResultCrnt >= numOfBox Then
Result(InxResult) = Empty
Else
' Discard unused trailing entries
ReDim Preserve ResultCrnt(0 To InxResultCrnt)
' Store this loop's combination in return array
Result(InxResult) = ResultCrnt
End If
Next
End Sub
Here's a version that does all the heavy lifting in variant arrays
(Combinations logic based on this answer for This Answer by Joubarc)
This runs on a sample dataset of 100 boxes with > 40,000 returned, and in < 1 second
Notes:
Execution time rises quickly if the Max number of boxes increases (eg 4 from 100: approx 13s)
If the number of returned results exceeds 65535, the code to tranpose the array into the sheet fails (last line of the sub) If you need to handle this may results, you will need to change the way results are returned to the sheet
Sub Demo()
Dim rNames As Range
Dim rHeights As Range
Dim rWeights As Range
Dim aNames As Variant
Dim aHeights As Variant
Dim aWeights As Variant
Dim MaxNum As Long
Dim MaxHeight As Double
Dim MaxWeight As Double
' *** replace these six line with your data ranges
Set rNames = Range([F5], [F5].End(xlToRight))
Set rHeights = rNames.Offset(1, 0)
Set rWeights = rNames.Offset(2, 0)
MaxNum = [C5]
MaxHeight = [C6]
MaxWeight = [C7]
aNames = rNames
aHeights = rHeights
aWeights = rWeights
Dim Result() As Variant
Dim n As Long, m As Long
Dim i As Long, j As Long
Dim iRes As Long
Dim res As String
Dim TestCombin() As Long
Dim TestWeight As Double
Dim TestHeight As Double
Dim idx() As Long
' Number of boxes
ReDim TestCombin(0 To MaxNum - 1)
n = UBound(aNames, 2) - LBound(aNames, 2) + 1
' estimate size of result array = number of possible combinations
For m = 1 To MaxNum
i = i + Application.WorksheetFunction.Combin(n, m)
Next
ReDim Result(1 To 3, 1 To i)
' allow for from 1 to MaxNum of boxes
iRes = 1
For m = 1 To MaxNum
ReDim idx(0 To m - 1)
For i = 0 To m - 1
idx(i) = i
Next i
Do
'Test current combination
res = ""
TestWeight = 0#
TestHeight = 0#
For j = 0 To m - 1
'Debug.Print aNames(1, idx(j) + 1);
res = res & aNames(1, idx(j) + 1)
TestWeight = TestWeight + aWeights(1, idx(j) + 1)
TestHeight = TestHeight + aHeights(1, idx(j) + 1)
Next j
'Debug.Print
If TestWeight <= MaxWeight And TestHeight <= MaxHeight Then
Result(1, iRes) = res
' optional, include actual Height and Weight in result
Result(2, iRes) = TestHeight
Result(3, iRes) = TestWeight
iRes = iRes + 1
End If
' Locate last non-max index
i = m - 1
While (idx(i) = n - m + i)
i = i - 1
If i < 0 Then
'All indexes have reached their max, so we're done
Exit Do
End If
Wend
'Increase it and populate the following indexes accordingly
idx(i) = idx(i) + 1
For j = i To m - 1
idx(j) = idx(i) + j - i
Next j
Loop
Next
' Return Result to sheet
Dim rng As Range
ReDim Preserve Result(1 To 3, 1 To iRes)
' *** Adjust returnm range to suit
Set rng = [E10].Resize(UBound(Result, 2), UBound(Result, 1))
rng = Application.Transpose(Result)
End Sub
Quick question that I've been struggling with. I have 2 arrays of different lengths that contain strings.
I want to output a new array which removes BOTH the elements if a duplicate is detected. At the moment it only removes duplicates but leaves the original which is incorrect for what I am trying to accomplish.
E.g.
input = array ("cat","dog","mouse","cat")
expected output = array ("dog","mouse")
actual output = array ("cat","dog","mouse")
Code is below:
Sub removeDuplicates(CombinedArray)
Dim myCol As Collection
Dim idx As Long
Set myCol = New Collection
On Error Resume Next
For idx = LBound(CombinedArray) To UBound(CombinedArray)
myCol.Add 0, CStr(CombinedArray(idx))
If Err Then
CombinedArray(idx) = Empty
dups = dups + 1
Err.Clear
ElseIf dups Then
CombinedArray(idx - dups) = CombinedArray(idx)
CombinedArray(idx) = Empty
End If
Next
For idx = LBound(CombinedArray) To UBound(CombinedArray)
Debug.Print CombinedArray(idx)
Next
removeBlanks (CombinedArray)
End Sub
Thanks for all help and support in advance.
What about using Scripting.Dictionary? Like this:
Function RemoveDuplicates(ia() As Variant)
Dim c As Object
Set c = CreateObject("Scripting.Dictionary")
Dim v As Variant
For Each v In ia
If c.Exists(v) Then
c(v) = c(v) + 1
Else
c.Add v, 1
End If
Next
Dim out() As Variant
Dim nOut As Integer
nOut = 0
For Each v In ia
If c(v) = 1 Then
ReDim Preserve out(nOut) 'you will have to increment nOut first, if you have 1-based arrays
out(nOut) = v
nOut = nOut + 1
End If
Next
RemoveDuplicates = out
End Function
Here is a quick example. Let me know if you get any errors.
Sub Sample()
Dim inputAr(5) As String, outputAr() As String, temp As String
Dim n As Long, i As Long
inputAr(0) = "cat": inputAr(1) = "Hen": inputAr(2) = "mouse"
inputAr(3) = "cat": inputAr(4) = "dog": inputAr(5) = "Hen"
BubbleSort inputAr
For i = 1 To UBound(inputAr)
If inputAr(i) = inputAr(i - 1) Or inputAr(i) = temp Then
inputAr(i - 1) = "": temp = inputAr(i): inputAr(i) = ""
End If
Next i
n = 0
For i = 1 To UBound(inputAr)
If inputAr(i) <> "" Then
n = n + 1
ReDim Preserve outputAr(n)
outputAr(n) = inputAr(i)
End If
Next i
For i = 1 To UBound(outputAr)
Debug.Print outputAr(i)
Next i
End Sub
Sub BubbleSort(arr)
Dim value As Variant
Dim i As Long, a As Long, b As Long, c As Long
a = LBound(arr): b = UBound(arr)
Do
c = b - 1
b = 0
For i = a To c
value = arr(i)
If (value > arr(i + 1)) Xor False Then
arr(i) = arr(i + 1)
arr(i + 1) = value
b = i
End If
Next
Loop While b
End Sub
EDIT
Another way without sorting
Sub Sample()
Dim inputAr(5) As String, outputAr() As String
Dim n As Long, i As Long, j As Long
Dim RemOrg As Boolean
inputAr(0) = "cat": inputAr(1) = "Hen": inputAr(2) = "mouse"
inputAr(3) = "cat": inputAr(4) = "dog": inputAr(5) = "Hen"
For i = 0 To UBound(inputAr)
For j = 1 To UBound(inputAr)
If inputAr(i) = inputAr(j) Then
If i <> j Then
inputAr(j) = "": RemOrg = True
End If
End If
Next
If RemOrg = True Then
inputAr(i) = ""
RemOrg = False
End If
Next i
n = 0
For i = 0 To UBound(inputAr)
If inputAr(i) <> "" Then
n = n + 1
ReDim Preserve outputAr(n)
outputAr(n) = inputAr(i)
End If
Next i
For i = 1 To UBound(outputAr)
Debug.Print outputAr(i)
Next i
End Sub