Brute Force Algorithm - algorithm

For no particular reason, other than I am interesting in cryptography and computing, I would like to make my own brute force program in Java or Visual Basic or C# to see if it can crack a password. I am not interested in performance and I am aware that it is a totally impractical method - it's just a bit of a fun project to be honest. However, I've only got a rough idea in my head and I can't even put it into psuedocode. I'm most proficient in Java but even if somebody could provide me with the psuedocode that'd be great!
I don't want to provide the program with a length, but I'll provide a maximum length. I know that the program will have to do a lot of work, but I do also think I am overthinking it a little.

The first thing you will want to do is figure out what you want to brute force. I would pick a one way hashing scheme, such as MD5 or SHA-1, that can be brute forced at high rates. After choosing which one way hashing scheme you want to "break", you will have to find some sort of password list, like http://www.whatsmypass.com/the-top-500-worst-passwords-of-all-time. After you have the list you need to hash the values and store them somewhere. After you have this stored "real" data set, you create your brute force loop and compare. When you find a match, output that match. You have now "cracked" a fake person password via brute force. Good luck!

Ok, so I just found an example what I wanted to do in C++ and I've managed to convert it to the following Visual Basic .NET code, which works perfectly. However the output seems a bit slow and I'd have thought the program would have used near 100% processing power, but it isn't. Could somebody tell me why this is and how I could change it please?
Public Class Form1
Dim chars() As Char = "1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYX".ToCharArray
Dim csize As Integer = chars.Length - 1
Dim upto As String
Private Sub btnGo_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles btnGo.Click
upto = " "
Dim max_length As Integer = 50
For i = 1 To max_length
bf_recursion(0, i)
Update()
Next
End Sub
Private Sub bf_recursion(ByVal index As Integer, ByVal depth As Integer)
Dim current() As Char = upto.ToCharArray()
For i = 0 To csize
current(index) = chars(i)
upto = CStr(current)
Console.WriteLine(CStr(current))
'\\lblOutput.Text = CStr(current)
If index <> (depth - 1) Then
bf_recursion(index + 1, depth)
End If
Next
End Sub
End Class

Hasan-G: yes i can
Dim chars() As Char = "1234567890abcdefghijklmnopqrstuvwxyz".ToCharArray
Dim csize As Integer = chars.Length - 1
Dim upto As String
Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click
upto = " "
Dim max_length As Integer = 25
For i = 1 To max_length
bf_recursion(0, i)
Update()
Next
End Sub
Private Sub bf_recursion(ByVal index As Integer, ByVal depth As Integer)
Dim current() As Char = upto.ToCharArray()
For i = 0 To csize
current(index) = chars(i)
upto = CStr(current)
TextBox1.Text = (CStr(current))
TextBox1.Refresh()
Me.Refresh()
'\\lblOutput.Text = CStr(current)
If index <> (depth - 1) Then
bf_recursion(index + 1, depth)
End If
Next
End Sub

while (true)
{
string[] mystring = new string[27];
mystring[0] = "";
mystring[1] = "a";
mystring[2] = "b";
mystring[3] = "c";
mystring[4] = "d";
mystring[5] = "e";
mystring[6] = "f";
mystring[7] = "g";
mystring[8] = "h";
mystring[9] = "i";
mystring[10] = "j";
mystring[11] = "k";
mystring[12] = "l";
mystring[13] = "m";
mystring[14] = "n";
mystring[15] = "o";
mystring[16] = "p";
mystring[17] = "q";
mystring[18] = "r";
mystring[19] = "s";
mystring[20] = "t";
mystring[21] = "u";
mystring[22] = "v";
mystring[23] = "w";
mystring[24] = "x";
mystring[25] = "y";
mystring[26] = "z";
if (counter == 27)
{
counter = 0;
counter2++;
}
if (counter2 == 27)
{
counter2 = 0;
counter3++;
}
if (counter3 == 27)
{
counter3 = 0;
counter4++;
}
if (counter4 == 27)
{
counter4 = 0;
counter5++;
}
if (counter5 == 27)
{
counter5 = 0;
counter6++;
}
if (counter6 == 27)
{
throw new Exception();
}
guessedpassword = mystring[counter6] + mystring[counter5] + mystring[counter4] + mystring[counter3] + mystring[counter2] + mystring[counter];
counter++;
}
Here is some code i have written. It is very inefficient at cracking, but is simple.

Related

vb6 random number no duplicates & no zeros

I am using vb6 and trying to generate a random number or String with this format
S1 = "378125649"
I have three requirements NO Duplicates Values & No Zeros & 9 charcters in length
I have approached This two very different ways the random number generator method is failing the FindAndReplace works but is too much code
The questions are
How to fix the GetNumber method code to meet the three requirement?
OR
How to simplify the FindAndReplace code to reflect a completely new sequence of numbers each time?
GetNumber code Below
Private Sub GetNumber()
Randomize
Dim MyRandomNumber As Long 'The chosen number
Dim RandomMax As Long 'top end of range to pick from
Dim RandomMin As Long 'low end of range to pick from
'Dim Kount As Long 'loop to pick ten random numbers
RandomMin = 1
RandomMax = 999999999
MyRandomNumber = Int(Rnd(1) * RandomMax) + RandomMin
lbOne.AddItem CStr(MyRandomNumber) & vbNewLine
End Sub
The FindAndReplace Code Below
Private Sub FindAndReplace()
Dim S4 As String
S4 = "183657429"
Dim T1 As String
Dim T2 As String
Dim J As Integer
Dim H As Integer
J = InStr(1, S4, 2)
H = InStr(1, S4, 8)
T1 = Replace(S4, CStr(J), "X")
T1 = Replace(T1, CStr(H), "F")
If Mid(T1, 8, 1) = "F" And Mid(T1, 2, 1) = "X" Then
T2 = Replace(T1, "F", "8")
T2 = Replace(T2, "X", "2")
End If
tbOne.Text = CStr(J) & " " & CStr(H)
lbOne.AddItem "Original Value " & S4 & vbNewLine
lbOne.AddItem "New Value " & T2 & vbNewLine
End Sub
Here's a way of generating 9-digit random numbers with no zeroes. The basic idea is to build a 9-character string position by position where each position is a random number between 1 and 9. Then each string is added to a collection to remove any duplicates. This code will generate 100,000 unique numbers:
Option Explicit
Private Sub Command1_Click()
Dim c As Collection
Set c = GetNumbers()
MsgBox c.Count
End Sub
Private Function GetNumbers() As Collection
On Error Resume Next
Dim i As Integer
Dim n As String
Randomize
Set GetNumbers = New Collection
Do While GetNumbers.Count < 100000
n = ""
For i = 1 To 9
n = n & Int((9 * Rnd) + 1)
Next
GetNumbers.Add n, n
Loop
End Function
In my testing, this code only generated 2 duplicates for the 100,000 unique numbers returned.
I don't have a VB6 compiler, so I winged it:
Function GetNumber(lowerLimit as Integer, upperLimit As Integer) As Integer
Dim randomNumber As String
Dim numbers As New Collection
Randomize
For i As Integer = lowerLimit To upperLimit
Call numbers.Add(i)
Next
For j As Integer = upperLimit To lowerLimit Step -1
Dim position As Short = Int(((j - lowerLimit)* Rnd) + 1)
randomNumber = randomNumber & numbers(position)
Call numbers.Remove(position)
Next
Return(CInt(randomNumber))
End Function
Use that function by calling for example:
GetNumber(1, 9)
I don't have VB6 on my machines anymore, so here's a solution written in Excel that shuffles the digits in 123456789 using an array.
You should be able to use it with little conversion:
Private Function RndNumber() As String
Dim i, j As Integer
Dim tmp As Variant
Dim digits As Variant
digits = Array("1", "2", "3", "4", "5", "6", "7", "8", "9")
For i = 0 To UBound(digits)
j = Int(9 * Rnd)
tmp = digits(i)
digits(i) = digits(j)
digits(j) = tmp
Next
RndNumber = Join(digits, "")
End Function
Here's a variation to play with that will shuffle an array you pass in and join them together with the specified separator. Note that the arrays being passed in are of variant type so anything can be shuffled. The first array has numbers while the second array has strings:
Private Sub Foo()
Dim digits As Variant
digits = Array(1, 2, 3, 4, 5, 6, 7, 8, 9)
Dim rndNnumber As String
RndNumber = ShuffleArrayAndJoin(digits, "")
Debug.Print RndNumber
Dim pets As Variant
pets = Array("cat", "dog", "fish", "hamster")
Dim rndPets As String
rndPets = ShuffleArrayAndJoin(pets, ", ")
Debug.Print (rndPets)
End Sub
Private Function ShuffleArrayAndJoin(ByVal sourceArray As Variant, ByVal separator As String) As String
Dim i, j As Integer
Dim tmp As Variant
For i = 0 To UBound(sourceArray)
j = Int(UBound(sourceArray) * Rnd)
tmp = sourceArray(i)
sourceArray(i) = sourceArray(j)
sourceArray(j) = tmp
Next
ShuffleArrayAndJoin = Join(sourceArray, separator)
End Function
Function GetNumber() As String
Dim mNum As String
Randomize Timer
Do While Len(mNum) <> 9
mNum = Replace(Str(Round(Rnd(Timer), 6)) + Str(Round(Rnd(Timer), 3)), " .", "")
Loop
GetNumber = mNum
End Function
Been clicking a button to load a text box for a couple of minutes, but so far no dupes, and I'd bet money there never will be any..
Well, it solves just 1 problem: it will never ever repeat number
but it has to be 15+ numbers long...
Function genRndNr(nrPlaces) 'must be more then 10
Dim prefix As String
Dim suffix As String
Dim pon As Integer
prefix = Right("0000000000" + CStr(DateDiff("s", "2020-01-01", Now)), 10)
suffix = Space(nrPlaces - 10)
For pon = 1 To Len(suffix)
Randomize
Randomize Rnd * 1000000
Mid(suffix, pon, 1) = CStr(Int(Rnd * 10))
Next
genRndNr = prefix + suffix
End Function

Change authKey of a user

Using SNMP version 3, I am creating a user.
Right now, I have it set up where I clone a user and that works just fine. However, I need to change the new user's authKey. How can I do this? I know the oid for authKeyChange, however, I don't know how to generate the new key. How do I generate that key? Can it be done using SNMPSharpNet?
If there is an easier way to do this while I'm creating the user, I can do that as well. ANY way to change the authKey (and privKey, but one step at a time) is much appreciated. I'm using VB.net if it means anything.
So I've figured out how to do this. It's a bit of a complex process. I followed this document, which is rfc2574. Do a ctrl+F for "keyChange ::=" and you'll find the paragraph walking you through the algorithm to generate the keyChange value. The following code has worked reliably to generate the keyChange value. All you have to do from this point is push the keyChange value to the usmAuthKeyChange OID. If you are changing the privacy password, you push the keyChange value to the usmPrivKeyChange OID. I'm ashamed to say that due to the time crunch, I did not have time to make this work completely, so when using SHA, I had to code an entirely new method that did almost the exact same thing. Again, I'm ashamed to post it, but I know how much I was banging my head against a wall, and if someone comes here later and sees this, I would like them to know what to do without going through the struggle.
Here is all of the code you need using VB.Net and the SNMPSharpNet library:
Private Function GenerateKeyChange(ByVal newPass As String, ByVal oldPass As String, ByRef target As UdpTarget, ByRef param As SecureAgentParameters) As Byte()
Dim authProto As AuthenticationDigests = param.Authentication
Dim hash As IAuthenticationDigest = Authentication.GetInstance(authProto)
Dim L As Integer = hash.DigestLength
Dim oldKey() As Byte = hash.PasswordToKey(Encoding.UTF8.GetBytes(oldPass), param.EngineId)
Dim newKey() As Byte = hash.PasswordToKey(Encoding.UTF8.GetBytes(newPass), param.EngineId)
Dim random() As Byte = Encoding.UTF8.GetBytes(GenerateRandomString(L))
Dim temp() As Byte = oldKey
Dim delta(L - 1) As Byte
Dim iterations As Integer = ((newKey.Length - 1) / L) - 1
Dim k As Integer = 0
If newKey.Length > L Then
For k = 0 To iterations
'Append random to temp
Dim merged1(temp.Length + random.Length - 1) As Byte
temp.CopyTo(merged1, 0)
random.CopyTo(merged1, random.Length)
'Store hash of temp in itself
temp = hash.ComputeHash(merged1, 0, merged1.Length)
'Generate the first 16 values of delta
For i = 0 To L - 1
delta(k * L + i) = temp(i) Xor newKey(k * L + i)
Next
Next
End If
'Append random to temp
Dim merged(temp.Length + random.Length - 1) As Byte
temp.CopyTo(merged, 0)
random.CopyTo(merged, temp.Length)
'Store hash of temp in itself
temp = hash.ComputeHash(merged, 0, merged.Length)
'Generate the first 16 values of delta
For i = 0 To (newKey.Length - iterations * L) - 1
delta(iterations * L + i) = temp(i) Xor newKey(iterations * L + i)
Next
Dim keyChange(delta.Length + random.Length - 1) As Byte
random.CopyTo(keyChange, 0)
delta.CopyTo(keyChange, random.Length)
Return keyChange
End Function
Private Function GenerateKeyChangeShaSpecial(ByVal newPass As String, ByVal oldPass As String, ByRef target As UdpTarget, ByRef param As SecureAgentParameters) As Byte()
Dim authProto As AuthenticationDigests = param.Authentication
Dim hash As IAuthenticationDigest = Authentication.GetInstance(authProto)
Dim L As Integer = 16
Dim oldKey() As Byte = hash.PasswordToKey(Encoding.UTF8.GetBytes(oldPass), param.EngineId)
Dim newKey() As Byte = hash.PasswordToKey(Encoding.UTF8.GetBytes(newPass), param.EngineId)
Array.Resize(oldKey, L)
Array.Resize(newKey, L)
Dim random() As Byte = Encoding.UTF8.GetBytes(GenerateRandomString(L))
Dim temp() As Byte = oldKey
Dim delta(L - 1) As Byte
Dim iterations As Integer = ((newKey.Length - 1) / L) - 1
Dim k As Integer = 0
If newKey.Length > L Then
For k = 0 To iterations
'Append random to temp
Dim merged1(temp.Length + random.Length - 1) As Byte
temp.CopyTo(merged1, 0)
random.CopyTo(merged1, random.Length)
'Store hash of temp in itself
temp = hash.ComputeHash(merged1, 0, merged1.Length)
Array.Resize(temp, L)
'Generate the first 16 values of delta
For i = 0 To L - 1
delta(k * L + i) = temp(i) Xor newKey(k * L + i)
Next
Next
End If
'Append random to temp
Dim merged(temp.Length + random.Length - 1) As Byte
temp.CopyTo(merged, 0)
random.CopyTo(merged, temp.Length)
'Store hash of temp in itself
temp = hash.ComputeHash(merged, 0, merged.Length)
Array.Resize(temp, L)
'Generate the first 16 values of delta
For i = 0 To (newKey.Length - iterations * L) - 1
delta(iterations * L + i) = temp(i) Xor newKey(iterations * L + i)
Next
Dim keyChange(delta.Length + random.Length - 1) As Byte
random.CopyTo(keyChange, 0)
delta.CopyTo(keyChange, random.Length)
Return keyChange
End Function
Private Function GenerateRandomString(ByVal length As Integer) As String
Dim s As String = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"
Dim r As New Random
Dim sb As New StringBuilder
For i As Integer = 1 To length
Dim idx As Integer = r.Next(0, 51)
sb.Append(s.Substring(idx, 1))
Next
Return sb.ToString()
End Function
Again, I am oh so well aware this code is hideous, but it works, and that is all I needed in the meantime. I understand this is technical debt and not the way I should code, but it's here and I hope you can get some use out of it.
If this doesn't work, don't forget to go to frc2574 and look at the algorithm.

Quick sort in Visual Basic

I tried to make a quick-sort in VB2015, however when I run it, the values don't sort fully (however it does almost sort). I'm fairly sure that the problem has something to do with the two recurring lines.
Private Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click
numbers = TextBox1.Text.Split()
Dim tempstring As String
Form2.Show()
tempstring = ""
quicksort(numbers, numbers.Length() - 1, 0)
For Each a As String In numbers
tempstring = tempstring + a + " "
Next
TextBox2.Text = tempstring
Form2.Show()
Form2.Chart1.Series(0).Points.DataBindY(numbers)
End Sub
Public Sub quicksort(list As Array, high As Integer, low As Integer)
MessageBox.Show(Str(high) + " " + Str(low))
ListView1.Items.Add(Str(high) + " " + Str(low))
Dim i As Integer
Dim pivot As Integer
'pivot = (high + low) / 2
pivot = high
If high > low + 1 And low >= 0 Then
i = low
For c = low + 1 To high
If Int(list(c)) <= Int(list(pivot)) Then
swap(list, c, i)
i = i + 1
End If
Next
quicksort(numbers, i - 2, low)
quicksort(numbers, high, i)
End If
End Sub
Public Sub swap(list As Array, x As Integer, y As Integer)
Dim temp As Integer
temp = list(x)
list(x) = list(y)
list(y) = temp
Form2.Chart1.Series(0).Points.DataBindY(numbers)
'pause()
End Sub
I know this is old, but somebody may come across this. Your SWAP sub needs to pass the parameters ByRef, or the swap is only taking place inside the sub's variables and not within your QuickSort routine.

Can anyone improve on the below Fuzzyfind function for VBA?

This function lets you find similar strings from a range without having to do an exact search.
The formula looks like this: =FuzzyFind(A1,B$1:B$20)
assuming the string you are performing a search for is in A1
and your reference or options table is B1:B20
The code is here:
Function FuzzyFind(lookup_value As String, tbl_array As Range) As String
Dim i As Integer, str As String, Value As String
Dim a As Integer, b As Integer, cell As Variant
For Each cell In tbl_array
str = cell
For i = 1 To Len(lookup_value)
If InStr(cell, Mid(lookup_value, i, 1)) > 0 Then
a = a + 1
cell = Mid(cell, 1, InStr(cell, Mid(lookup_value, i, 1)) - 1) & Mid(cell, InStr(cell, Mid(lookup_value, i, 1)) + 1, 9999)
End If
Next i
a = a - Len(cell)
If a > b Then
b = a
Value = str
End If
a = 0
Next cell
FuzzyFind = Value
End Function
The results from this function are hit and miss. Can anyone improve the intelligence of this algorithm?
Thank you :)
I'm not sure exactly what "FuzzyFind" entails, but this is a VLOOKUP that uses the Levenshtein distance to find similar data.
The Levenshtein distance lets you select a "percentage match" that you can specify instead of the typical TRUE or FALSE from a normal VLOOKUP:
Usage is: DTVLookup(A1,$C$1:$C$100,1,90) where 90 is the Levenshtein Distance.
DTVLookup(Value To Find, Range to Search, Column to Return, [Percentage Match])
I typically use this when comparing names that come from different databases like:
Correct Name Example Lookup Percentage Match Other Report
John S Smith John Smith 83 John Smith
Barb Jones Barbara Jones 77 Barbara Jones
Jeffrey Bridge Jeff Bridge 79 Jeff Bridge
Joseph Park Joseph P. Park 79 Joseph P. Park
Jefrey Jones jefre jon 75 jefre jon
Peter Bridge peter f. bridge 80 peter f. bridge
Here's the code:
Function DTVLookup(TheValue As Variant, TheRange As Range, TheColumn As Long, Optional PercentageMatch As Double = 100) As Variant
If TheColumn < 1 Then
DTVLookup = CVErr(xlErrValue)
Exit Function
End If
If TheColumn > TheRange.Columns.Count Then
DTVLookup = CVErr(xlErrRef)
Exit Function
End If
Dim c As Range
For Each c In TheRange.Columns(1).Cells
If UCase(TheValue) = UCase(c) Then
DTVLookup = c.Offset(0, TheColumn - 1)
Exit Function
ElseIf PercentageMatch <> 100 Then
If Levenshtein3(UCase(TheValue), UCase(c)) >= PercentageMatch Then
DTVLookup = c.Offset(0, TheColumn - 1)
Exit Function
End If
End If
Next c
DTVLookup = CVErr(xlErrNA)
End Function
Function Levenshtein3(ByVal string1 As String, ByVal string2 As String) As Long
Dim i As Long, j As Long, string1_length As Long, string2_length As Long
Dim distance(0 To 60, 0 To 50) As Long, smStr1(1 To 60) As Long, smStr2(1 To 50) As Long
Dim min1 As Long, min2 As Long, min3 As Long, minmin As Long, MaxL As Long
string1_length = Len(string1): string2_length = Len(string2)
distance(0, 0) = 0
For i = 1 To string1_length: distance(i, 0) = i: smStr1(i) = Asc(LCase(Mid$(string1, i, 1))): Next
For j = 1 To string2_length: distance(0, j) = j: smStr2(j) = Asc(LCase(Mid$(string2, j, 1))): Next
For i = 1 To string1_length
For j = 1 To string2_length
If smStr1(i) = smStr2(j) Then
distance(i, j) = distance(i - 1, j - 1)
Else
min1 = distance(i - 1, j) + 1
min2 = distance(i, j - 1) + 1
min3 = distance(i - 1, j - 1) + 1
If min2 < min1 Then
If min2 < min3 Then minmin = min2 Else minmin = min3
Else
If min1 < min3 Then minmin = min1 Else minmin = min3
End If
distance(i, j) = minmin
End If
Next
Next
' Levenshtein3 will properly return a percent match (100%=exact) based on similarities and Lengths etc...
MaxL = string1_length: If string2_length > MaxL Then MaxL = string2_length
Levenshtein3 = 100 - CLng((distance(string1_length, string2_length) * 100) / MaxL)
End Function
Try this out, I think it will find the best match
Function FuzzyFind2(lookup_value As String, tbl_array As Range) As String
Dim i As Integer, str As String, Value As String
Dim a As Integer, b As Integer, cell As Variant
Dim Found As Boolean
b = 0
For Each cell In tbl_array
str = cell
i = 1
Found = True
Do While Found = True
Found = False
If InStr(i, str, lookup_value) > 0 Then
a = a + 1
Found = True
i = InStr(i, str, lookup_value) + 1
End If
Loop
If a > b Then
b = a
Value = str
End If
a = 0
Next cell
FuzzyFind2 = Value
End Function
I've been looking for this theme a lot and definitely Holmes IV answer is the best. I would just add a small update to compare always in uppercase. For my problems it recommended me more accurate options.
Function FuzzyFind3(lookup_value As String, tbl_array As Range) As String
Dim i As Integer, str As String, Value As String
Dim a As Integer, b As Integer, cell As Variant
Dim Found As Boolean
b = 0
For Each cell In tbl_array
str = UCase(cell)
i = 1
Found = True
Do While Found = True
Found = False
If InStr(i, str, UCase(lookup_value)) > 0 Then
a = a + 1
Found = True
i = InStr(i, str, UCase(lookup_value)) + 1
End If
Loop
If a > b Then
b = a
Value = str
End If
a = 0
Next cell
FuzzyFind3 = Value

VBA - Remove both items from array when not unique

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

Resources