Have almost no experience in VBA. Please, help to figure out what i'm doing wrong. DataBase is a Collection each element of which is an array of 5 String-type elements describing some object. I'm trying to sort collection by particular element of an array. At this fragment of code a get "Run-time error 13. Type mismatch".
Dim DataBase As New Collection
For i = 1 To DataBase.Count - 1
For j = i + 1 To DataBase.Count
If DataBase.Item(i)(1) > DataBase.Item(j)(1) Then
temp = DataBase(j)
DataBase.Remove (j)
DataBase.Add temp, temp, i
End If
Next j
Next i
Tried accessing to elements of collection using Collection.Item (Index) and Collection(Index) bur cannot get the sorted collection.
Sort Collection of Same-Sized Arrays By First Element of Each Array
A Quick Fix
If DataBase(i)(1) > DataBase(j)(1) Then
Temp = DataBase(j)
DataBase.Remove j ' redundant parentheses
DataBase.Add Temp, , i ' the cause of the type mismatch
End If
In Detail (A Working Example)
Option Explicit
Sub CollSort()
Const collCount As Long = 10
Dim Strs(): Strs = Array("G", "C", "D", "F", "H", "B", "E", "I", "J", "A")
' Populate the collection with the arrays, and each array's first element
' using the strings from the 'Strs' array.
Dim coll As Collection: Set coll = New Collection
Dim arr() As String: ReDim arr(1 To 5)
Dim n As Long
For n = 1 To collCount
arr(1) = Strs(n - 1)
coll.Add arr
Next n
' Print populated data (only the first element of each array).
Dim Item As Variant
Debug.Print "Initial"
For Each Item In coll
Debug.Print Item(1)
Next Item
' Bubble sort by the first element of each array.
' Note that the arrays are being swapped, not their first elements.
Dim Temp, i As Long, j As Long
For i = 1 To coll.Count - 1
For j = i + 1 To coll.Count
If coll(i)(1) > coll(j)(1) Then
Temp = coll(j)
coll.Remove j
coll.Add Temp, , i
End If
Next j
Next i
' Print sorted data (only the first element of each array).
Debug.Print "Sorted"
For Each Item In coll
Debug.Print Item(1)
Next Item
End Sub
Related
I am creating a third party add in for my CAD program that has a sub in it that goes through a drawing and finds all the parts lists (BOMS), if any items in the parts list are shared between the BOM (1 part being used in 2 weldments for example) then it changes the item number of the second instance to be that of the first instance. It does this by comparing full file names between the two values. When they match change the number to that of the matcher. I have got this to work but it runs a little slow because for a 100 item BOM each item is compared to 100 and thus that takes a little longer then I would like (about 60seconds to run). After thinking about it I realized I did not need to compare each item to all the items, I just needed to compare until it found a duplicate and then exit the search loop and go to the next value. Example being Item 1 does not need to compare to the rest of the 99 values because even if it does have a match in position 100 I do not want to change item 1s number to that of item 100. I want to change item 100 to that of 1(ie change the duplpicate to that of the first encountered double). For my code however I am having trouble exiting the comparison for loops which is causing me trouble. An example of the trouble is this:
I have 3 BOMs, each one shares Part X, and is numbered 1 in BOM 1, 4 in BOM 2, and 7 in BOM 3. when I run my button because I cannot get it to leave the comparison loop once it finds it first match all the Part X's ended up getting item number 7 from BOM 3 because it is the last instance. (I can get this to do what I want by stepping through my for loops backwards and thus everything ends up as the top most occurrence, but I would like to get my exit fors working because it saves me on unnecessary comparisons)
How do I go about breaking out of the nested for loops using an if conditional?
Here is my current code:
Public Sub MatchingNumberR1()
Debug.Print ThisApplication.Caption
'define active document as drawing doc. Will produce an error if its not a drawing doc
Dim oDrawDoc As DrawingDocument
Set oDrawDoc = ThisApplication.ActiveDocument
'Store all the sheets of drawing
Dim oSheets As Sheets
Set oSheets = oDrawDoc.Sheets
Dim oSheet As Sheet
'Loop through all the sheets
For Each oSheet In oSheets
Dim oPartsLists As PartsLists
Set oPartsLists = oSheet.PartsLists
'Loop through all the part lists on that sheet
Dim oPartList As PartsList
'For every parts list on the sheet
For Each oPartList In oPartsLists
For i3 = 1 To oPartList.PartsListRows.Count
'Store the Item number and file referenced in that row to compare
oItem = FindItem(oPartList)
oDescription = FindDescription(oPartList)
oDescripCheck = oPartList.PartsListRows.Item(i3).Item(oDescription).Value
oNumCheck = oPartList.PartsListRows.Item(i3).Item(oItem).Value
'Check to see if the BOM item is a virtual component if it is do not try and get the reference part
If oPartList.PartsListRows.Item(i3).ReferencedFiles.Count = 0 Then
oRefPart = " "
End If
'Check to see if the BOM item is a virtual component if it is try and get the reference part
If oPartList.PartsListRows.Item(i3).ReferencedFiles.Count > 0 Then
oRefPart = oPartList.PartsListRows.Item(i3).ReferencedFiles.Item(1).FullFileName
End If
MsgBox (" We are comparing " & oRefPart)
'''''Create a comparison loop to go through the drawing that checks the oRefPart against other BOM items and see if there is a match.'''''
'Store all the sheets of drawing
Dim oSheets2 As Sheets
Set oSheets2 = oDrawDoc.Sheets
Dim oSheet2 As Sheet
'For every sheet in the drawing
For Each oSheet2 In oSheets2
'Get all the parts list on a single sheet
Dim oPartsLists2 As PartsLists
Set oPartsLists2 = oSheet2.PartsLists
Dim oPartList2 As PartsList
'For every parts list on the sheet
For Each oPartList2 In oPartsLists2
oItem2 = FindItem(oPartList2)
oDescription2 = FindDescription(oPartList2)
'Go through all the rows of the part list
For i6 = 1 To oPartList2.PartsListRows.Count
'Check to see if the part is a not a virtual component, if not, get the relevent comparison values
If oPartList2.PartsListRows.Item(i6).ReferencedFiles.Count > 0 Then
oNumCheck2 = oPartList2.PartsListRows.Item(i6).Item(oItem2).Value
oRefPart2 = oPartList2.PartsListRows.Item(i6).ReferencedFiles.Item(1).FullFileName
'Compare the file names, if they match change the part list item number for the original to that of the match
If oRefPart = oRefPart2 Then
oPartList.PartsListRows.Item(i3).Item(1).Value = oNumCheck2
''''''''This is where I want it to exit the loop and grab the next original value'''''''
End If
'For virtual components get the following comparison values
ElseIf oPartList2.PartsListRows.Item(i6).ReferencedFiles.Count = 0 Then
oNumCheck2 = oPartList2.PartsListRows.Item(i6).Item(oItem2).Value
oDescripCheck2 = oPartList2.PartsListRows.Item(i6).Item(oDescription2).Value
'Compare the descriptions and if they match change the part list item number for the original to that of the match
If oDescripCheck = oDescripCheck2 Then
oPartList.PartsListRows.Item(i3).Item(1).Value = oNumCheck2
''''''''This is where I want it to exit the loop and grab the next original value'''''''
End If
Else
''''''''This is where if no matches were found I want it to continue going through the comparison loop'''''''
End If
Next
Next
Next
Next
Next
Next
'MsgBox ("Matching Numbers has been finished")
End Sub
For escape from nested for loop you can use GoTo and specify where.
Sub GoToTest()
Dim a, b, c As Integer
For a = 0 To 1000 Step 100
For b = 0 To 100 Step 10
For c = 0 To 10
Debug.Print vbTab & b + c
If b + c = 12 Then
GoTo nextValueForA
End If
Next
Next
nextValueForA:
Debug.Print a + b + c
Next
End Sub
Here are a few examples that demonstrate (1) breaking out of (exiting) a loop and (2) finding the values in arrays.
The intersection of 2 arrays example can be modified to meet your need to "Create a comparison loop to go through the drawing that checks the oRefPart against other BOM items and see if there is a match." Note, you may find multiple matches between 2 arrays.
Option Explicit
Option Base 0
' Example - break out of loop when condition met.
Public Sub ExitLoopExample()
Dim i As Integer, j As Integer
' let's loop 101 times
For i = 0 To 100:
j = i * 2
'Print the current loop number to the Immediate window
Debug.Print i, j
' Let's decide to break out of the loop is some
' condition is met. In this example, we exit
' the loop if j>=10. However, any condition can
' be used.
If j >= 10 Then Exit For
Next i
End Sub
' Example - break out of inner loop when condition met.
Public Sub ExitLoopExample2()
Dim i As Integer, j As Integer
For i = 1 To 5:
For j = 1 To 5
Debug.Print i, j
' if j >= 2 then, exit the inner loop.
If j >= 2 Then Exit For
Next j
Next i
End Sub
Public Sub FindItemInArrayExample():
' Find variable n in array arr.
Dim intToFind As Integer
Dim arrToSearch As Variant
Dim x, y
intToFind = 4
arrToSearch = Array(1, 2, 3, 4, 5, 6, 7, 8, 9)
x = FindItemInArray(FindMe:=intToFind, _
ArrayToSearch:=arrToSearch)
If IsEmpty(x) Then
Debug.Print intToFind; "not found in arrToSearch"
Else
Debug.Print "found "; x
End If
intToFind = 12
y = FindItemInArray(FindMe:=intToFind, _
ArrayToSearch:=arrToSearch)
If IsEmpty(y) Then
Debug.Print intToFind; "not found in arrToSearch"
Else
Debug.Print "found "; y
End If
End Sub
Public Function FindItemInArray(FindMe, ArrayToSearch As Variant):
Dim i As Integer
For i = LBound(ArrayToSearch) To UBound(ArrayToSearch)
If FindMe = ArrayToSearch(i) Then
FindItemInArray = ArrayToSearch(i)
Exit For
End If
Next i
End Function
' Create a comparison loop to go through the drawing that checks
' the oRefPart against other BOM items and see if there is a match.
Public Sub ArrayIntersectionExample():
Dim exampleArray1 As Variant, exampleArray2 As Variant
Dim arrIntersect As Variant
Dim i As Integer
' Create two sample arrays to compare
exampleArray1 = Array(1, 2, 3, 4, 5, 6, 7)
exampleArray2 = Array(2, 4, 6, 8, 10, 12, 14, 16)
' Call our ArrayIntersect function (defined below)
arrIntersect = ArrayIntersect(exampleArray1, exampleArray2)
' Print the results to the Immediate window
For i = LBound(arrIntersect) To UBound(arrIntersect)
Debug.Print "match " & i + 1, arrIntersect(i)
Next i
End Sub
Public Function ArrayIntersect(arr1 As Variant, arr2 As Variant) As Variant:
' Find items that exist in both arr1 and arr2 (intersection).
' Return the intersection as an array (Variant).
Dim arrOut() As Variant
Dim matchIndex As Long
Dim i As Long, j As Long
' no matches yet
matchIndex = -1
' begin looping through arr1
For i = LBound(arr1) To UBound(arr1)
' sub-loop for arr2 for each item in arr1
For j = LBound(arr2) To UBound(arr2)
' check for match
If arr1(i) = arr2(j) Then
' we found an item in both arrays
' increment match counter, which we'll
' use to size our output array
matchIndex = matchIndex + 1
' resize our output array to fit the
' new match
ReDim Preserve arrOut(matchIndex)
' now store the new match our output array
arrOut(matchIndex) = arr1(i)
End If
Next j
Next i
' Have the function return the output array.
ArrayIntersect = arrOut
End Function
Say you would like to set up a very simple Caesar Cipher, where A --> 1, B --> 2 ... etc.
Say you have a word "Hello" in a cell that you would like to encrypt. You can set up a very simple For Loop to loop through each word:
For i = 1 To Len("Hello")
'perform encryption here
Next i
Is there a quick an easy way to map values from a pre-defined range? I.e. we know that A = 1, or 1 + 26, or 1 + 2*(26) .. etc...
Rather than writing IF statement to check for all letters, I wonder if there is an elegant way of doing this to get: "8 5 12 12 15"
Get the cell's output as a string with Byte array:
Dim brr() As Byte, i As Long, k As String
brr() = StrConv(Cells(1, 3), vbFromUnicode)
Then assess each letter in the new array against a larger array:
dim arr as variant
arr = array("a", "b")
For i = 0 To UBound(brr) 'need to start at 0, lbound applies for std array, not byte
'match brr value to arr value, output arr location
'k will store the final string
k = k + 'didn't look up the output for application.match(arr())
Next i
Edit1: Thanks to JohnColeman, i can add Asc() to the above and it shouldn't need the additional array for A, B, C, etc.
Dim brr() As Byte, i As Long, k As String
brr() = StrConv(Cells(1, 3), vbFromUnicode)
for i = 0 To UBound(brr)
k = k & " " & Asc(brr(i)) 'something like that
next i
Using the Dictionary route, you can build a dictionary which is a list of key, value pairs to hold your cypher. In your case the key of a would have the value 1 and the key of b would have the value 2, and so on. Then you can just bump your word, letter by letter, against the dictionary to build your cipher:
Function caesarCipher(word As String) As String
'create an array of letters in their position for the cipher (a is 1st, b is 2nd)
Dim arrCipher As Variant
arrCipher = Split("a b c d e f g h i j k l m n o p q r s t u v x y z", " ")
'Create a dictionary from the array with the key being the letter and the item being index + 1
Dim dictCipher As Scripting.Dictionary
Set dictCipher = New Dictionary
For i = 0 To UBound(arrCipher)
dictCipher.Add arrCipher(i), i + 1
Next
'Now loop through the word letter by letter
For i = 1 To Len(word)
'and build the cipher output
caesarCipher = caesarCipher & IIf(Len(caesarCipher) = 0, "", " ") & dictCipher(LCase(Mid(word, i, 1)))
Next
End Function
This is a nice way of doing it because you can change your cipher to be whatever you want and you only need monkey with your dictionary. Here I just build a dictionary from an array and use the array's index for the cipher output.
This might get you started:
Function StringToNums(s As String) As Variant
'assumes that s is in the alphabet A, B, ..., Z
Dim nums As Variant
Dim i As Long, n As Long
n = Len(s)
ReDim nums(1 To n)
For i = 1 To n
nums(i) = Asc(Mid(s, i, 1)) - Asc("A") + 1
Next i
StringToNums = nums
End Function
Sub test()
Debug.Print Join(StringToNums("HELLO"), "-") 'prints 8-5-12-12-15
End Sub
All of the answers are good, but this is how you use a dictionary which is simpler and more straight-forward. I defined the dictionary implicitly to make it easier to start, but it is better to define it explicitly by adding runtime scripting from the tools>references in VBE.
Sub Main()
Dim i As Integer
Dim ciphered As String, str As String
Dim dict As Object
Set dict = CreateObject("scripting.Dictionary")
str = "Hello"
For i = 65 To 122
dict.Add Chr(i), i - 64
Next i
For i = 1 To Len(str)
ciphered = ciphered & "-" & dict(Mid(UCase(str), i, 1))
Next i
ciphered = Right(ciphered, Len(ciphered) - 1)
Debug.Print ciphered
End Sub
if you remove ucase when getting the code from the dictionary it will count for the case meaning that uppercase or lowercase will have different codes. You can change this to a function easily, don't forget to remove str = "Hello". Right now it returns:
Output
8-5-12-12-15
I have a function meant to return an array which is created out of a single-column list of data. I have been using this function's return value essentially as a pseudo-global variable (LINENAMES_ARRAY) which I pass to many functions. Those functions than do checks on it such as If Len(Join(LINENAMES_ARRAY)) = 0 Then or go through items with For Each statements. Here is the code:
Function LINENAMES_ARRAY() As Variant
'returns an array of all items in the main sheet linenames column
LINENAMES_ARRAY = Application.Transpose(MAIN.Range( _
MAIN.Cells(MAIN_HEAD_COUNT + 1, MAIN_LINENAMES_COLUMN), _
MAIN.Cells(LINENAMES_COUNT + 1, MAIN_LINENAMES_COLUMN)))
End Function
I recently stumbled on one of those you-don't-see-it-till-you-see-it problems while using this workbook for a new project, where if the array happens to be only 1 element, everything fails. Apparently in that case, this returns a single value so Join() will fail For Each __ in LINENAMES_ARRAY will too. Why won't it treat this as a 1x1 array rather than a free value? I have started to mitigate the problem by rewriting functions where this is called, to check whether it is an array, then do some other procedure. Things like:
For j = 1 To LINENAMES_COUNT
LINES_BOX.AddItem lineNames(j)
Next j
is changed to:
If Not IsArray(LINENAMES_ARRAY) Then
myListBox.AddItem CStr(LINENAMES_ARRAY)
Else
For j = 1 To LINENAMES_COUNT
LINES_BOX.AddItem LINENAMES_ARRAY(j)
Next j
End If
However this becomes messy and is adding many extra checks to my code that I would prefer to handle in the LINENAMES_ARRAY function. Is there a way to return a 1x1 array? Or any other workaround?
An array can have a single element if you create it as a single element array and populate it in an array manner.
Option Explicit
Dim MAIN_HEAD_COUNT As Long
Dim LINENAMES_COUNT As Long
Dim MAIN_LINENAMES_COLUMN As Long
Dim MAIN As Worksheet
Sub stuff()
Dim arr As Variant
Set MAIN = Worksheets("Sheet1")
MAIN_LINENAMES_COLUMN = 2
MAIN_HEAD_COUNT = 2
LINENAMES_COUNT = 2
arr = LINENAMES_ARRAY()
Debug.Print IsArray(arr)
Debug.Print LBound(arr) & ":" & UBound(arr)
End Sub
Function LINENAMES_ARRAY() As Variant
Dim a As Long, tmp() As Variant
ReDim tmp(0 To LINENAMES_COUNT - MAIN_HEAD_COUNT)
For a = 0 To LINENAMES_COUNT - MAIN_HEAD_COUNT
tmp(a) = MAIN.Range(MAIN.Cells(MAIN_HEAD_COUNT + 1, MAIN_LINENAMES_COLUMN), _
MAIN.Cells(LINENAMES_COUNT + 1, MAIN_LINENAMES_COLUMN)).Cells(a).Value2
Next a
'returns an array of all items in the main sheet linenames column
LINENAMES_ARRAY = tmp
End Function
Results from the VBE's Immediate window:
True
0:0
I need to create a bunch of dictionaries in VBA; the best solution is to concatenate prefix "dict" with a string variable (enumeration would cause more complexities). Is there a way to convert a string into a VBA statement?
For example, I have a dictionary dictABC created. How to refer to it by using two segment of strings, "dict" and "ABC" concatenated?
(The only way I could think of is to create a "meta-dictionary", with pairs of string "dictABC" and dictionary dictABC.)
If you build an array of dictionary objects and use another single dictionary to act as the index of all of the dictionaries you've created, you should get something akin to what you have described. Consider the following data that has three unique values in Col A.
Col A Col B Col C Col D
Y 196 RNT 4-Jan-2015
Y 127 IYI 12-Feb-2015
X 173 ZVM 24-Jan-2015
Z 124 LRP 16-Jan-2015
Z 176 XTN 27-Jan-2015
Y 137 SUG 30-Jan-2015
X 139 IBG 7-Feb-2015
X 165 DON 11-Feb-2015
Z 153 EUU 16-Feb-2015
After adding Microsoft Scripting Runtime to the VBE's Tools ► References we can run down column A, adding a key entry and index number to the index of dictionaries then redimming the array of dictionaries for room and populating that new dictionary object. If a value in column A already exists, the dNDX is used to figure out which dictionary object in the array should be referenced and adds a new key/item.
Sub mcr_Dict_Over_Dicts()
Dim rw As Long, d As Long, sCOLa As String, ky As Variant
Dim dNDX As New Scripting.Dictionary, dDICTs() As New Scripting.Dictionary
dNDX.CompareMode = TextCompare 'or BinaryCompare
With ActiveSheet
For rw = 2 To .Cells(Rows.Count, 1).End(xlUp).Row
sCOLa = .Cells(rw, 1).Value
If CBool(Len(sCOLa)) Then
If Not dNDX.Exists(sCOLa) Then
'create a new entry in dNDX and a new dictionary in the array
d = dNDX.Count + 1
dNDX.Add Key:=sCOLa, Item:=d
ReDim Preserve dDICTs(1 To d)
dDICTs(d).Add Key:=.Cells(rw, 2).Text, _
Item:=Join(Array(.Cells(rw, 1).Text, .Cells(rw, 2).Text, .Cells(rw, 3).Text, .Cells(rw, 4).Text), ChrW(8203))
Else
'add an entry to an existing dictionary
dDICTs(dNDX.Item(sCOLa)).Add Key:=.Cells(rw, 2).Text, _
Item:=Join(Array(.Cells(rw, 1).Text, .Cells(rw, 2).Text, .Cells(rw, 3).Text, .Cells(rw, 4).Text), ChrW(8203))
End If
End If
Next rw
'return the values to the worksheet reordered in an alternate location
.Cells(1, 6).Resize(1, 4) = .Cells(1, 1).Resize(1, 4).Value
For d = LBound(dDICTs) To UBound(dDICTs)
For Each ky In dDICTs(d)
.Cells(Rows.Count, 6).End(xlUp).Offset(1, 0).Resize(1, 4) _
= Split(dDICTs(d).Item(ky), ChrW(8203))
Next ky
Next d
End With
For d = LBound(dDICTs) To UBound(dDICTs)
dDICTs(d).RemoveAll
Next d
'alternately redim dDICTs
ReDim dDICTs(1)
dNDX.RemoveAll
Set dNDX = Nothing
End Sub
This does demand that there will be some value or combination of values (hash) that can be used as a unique key within each of the dictionaries in the array.
Note that the results in columns G and I are text based. This is a result of them being split out of a concatenated string.
I'm confused why you've thought of and for some reason rejected the simple, obvious solution.
But if you really want to go the code generation route, this is how you would do it.
Function dictAbcd() As Object
Static result As Object
If result Is Nothing Then
Set result = CreateObject("Scripting.Dictionary")
End If
Set dictAbcd = result
End Function
Public Sub Test()
Dim x As Object
Dim dict_index As String
dictAbcd("key") = "value"
dict_index = "Abcd"
Set x = Application.Run("dict" & dict_index)
Debug.Print x("key") ' Prints "value"
End Sub
N.b. doing it this way is completely ridiculous.
You could put the dictionaries into a collection, which allows you to have a string index.
Let me start by first thanking everyone for the help/intention to help. This community is phenomenal. Second: I'm pretty new at this- before this week I'd learned basic in highschool a decade ago but no other programming experience outside of theory.
Without further ado, here's my issue:
Working on code to find unique variables (I know there's a lot of opensource stuff out there, need to customize this though). When I go to populate the array with the very first string I run into an 'out of range' error at array(1), which I had explicity set (1 TO UB), with UB being the upper bound. I've also double checked the value of UB with msgbox and it's at 15 with my dummy data, so that shouldn't be an issue. I've set the values in the array to empty (have also done so with 0, to no avail).
The error occurs at "ResultArray(1) = CurrentArray(1)"
I'm at a loss; any assistance would be much appreciated.
Option Explicit
Sub unque_values()
'''''''''Variable declaration
'
' CurrentArray() is the array taken from the worksheet
' Comp is the method of comparing inputs (either case sensitive or case insensitive)
' resultarray() is the array that unique values are placed
' UB is the upper bound of Result Array
' resultindex is the variable that keeps track of which cells are unique and which are not
' n is a helped variable that assists with resizing the array
Dim currentarray() As Variant
Dim comp As VbCompareMethod
Dim resultarray() As Variant
Dim UB As Long
Dim resultindex As Long
Dim n As Long
Dim v As Variant
Dim inresults As Boolean
Dim m As Long
' set variables to default values
Let comp = vbTextCompare
Let n = 0
' count the number of cells included in currentarray and populate with values
Let n = ActiveWorkbook.Worksheets("Data").Range("A:A").Count
Let UB = ActiveWorkbook.Worksheets("Data").Range("A" & n).End(xlUp).Row
' dimension arrays
ReDim resultarray(1 To UB)
ReDim currentarray(1 To UB)
' don't forget to change to named ranges
Let currentarray() = Range("f2", "f" & UB)
' populate resultarray with empty values
For n = LBound(resultarray) To UBound(resultarray)
resultarray(n) = Empty
Next n
MsgBox (n)
'check for invalid values in array
For Each v In currentarray
If IsNull(n) = True Then
resultarray = CVErr(xlErrNull)
Exit Sub
End If
Next v
' assumes the first value is unique
resultindex = 1
'''''''''''''''''''''''''''''''''''''''''error is this line''''''''''''''
resultarray(1) = currentarray(1)
' Search for duplicates by cycling through loops
' n = index of value being checked
' m = index of value being checked against
For n = 2 To UB
Let inresults = False
For m = 1 To n
If StrComp(CStr(resultarray(m)), CStr(currentarray(n)), comp) = 0 Then
inresults = True
Exit For
End If
Next m
If inresults = False Then
resultindex = resultindex + 1
resultarray(resultindex) = currentarray(n)
End If
Next n
ReDim Preserve resultarray(1 To resultindex)
End Sub
You've assigned to currentArray a range array. These are always two-dimensional arrays.
You should be able to resolve it with:
resultarray(1) = currentarray(1, 1)
You would need to modify a few more lines in your code to refer to both dimensions of the array.
Alternatively, with the least manipulation to your existing code, transpose the array which turns it to a one-dimensional array. This should require no other changes to your code.
Let currentArray() = Application.Transpose(Range("f2", "f" & UB))
Try with ActiveWorkbook.Worksheets("Data").UsedRange.Columns(1).cells.Count