VBA ArrayList Of Arrays - arrays

I have a list of 2 columns that A has a random number associated with it and B has a string item. So i was thinking I could make any Arraylist of arrays, but i would like to make the name of the Array the number so it can quickly be referenced. I've tried
Dim row As Integer
Dim arrList As Object
Dim arr As Variant
arrList = CreateObject("System.Collections.ArrayList")
row = 1
While Not IsEmpty(ActiveSheet.Range("A" & row))
ReDim arr(0 To 1) As String
arr(0) = ActiveSheet.Range("A" & row)
arr(1) = ActiveSheet.Range("B" & row)
arrList.Add (arr)
row = row + 1
Wend
Is there a quick way to search ArrList(arr(0)?

You probably should be using the Dictionary object (https://support.microsoft.com/en-us/kb/187234) and (Does VBA have Dictionary Structure?).
You can use .Exists to check if your key/item exists in the Dictionary or not.
Dim dctMyList As Dictionary
Dim nCount As Integer
Dim sKey As String
Set dctMyList = New Dictionary
For nCount = 1 To 5
sKey = "Fruit_" & nCount
dctMyList.Add sKey, Choose(nCount, "Apple", "Banana", "Date", "Fig", "Pear")
Next nCount
If dctMyList.Exists("Fruit_2") Then
Debug.Print dctMyList.Items(1)
Else
' Do something else
End If
Note that you can use .Items to access the contents, which is a zero-based index. So in the above example, "Banana" is the second item added to the Dictionary, but has an index of 1.

Related

edit dimension of array vba

I have an array like this
dim arr(1 to 5) as string
arr(1)="a"
arr(3)="b"
arr(5) = "c"
(arr(2),arr(4) are empty).
How can I redim this arr(1to5) to exclude empty values and save also values "a","b","c" (I want the output like arr(1to3), arr(1)="a", arr(2)="b", arr(3)="c")?
In general I do not know how many of them will be empty, so I need some general code for this (not for this specific example).
I was thinking about new temporary array to save all nonempty values and then redim arr(1to5).
Maybe it is a better (quick) way to do it?
I wrote sth similar:
Sub test()
Dim myArray() As String
Dim i As Long
Dim y As Long
ReDim Preserve myArray(3)
myArray(1) = "a"
myArray(3) = "c"
Dim myArray2() As String
y = 1
For i = LBound(myArray) To UBound(myArray)
If myArray(i) <> "" Then
ReDim Preserve myArray2(y)
myArray2(y) = myArray(i)
y = y + 1
End If
Next i
ReDim myArray(UBound(myArray2))
myArray = myArray2
End Sub
However I would like to avoid creating new array.
create a new array of the same size. Loop the first array and insert the values when not empty into the new array keeping track of the last spot with value in the new array, then redim preserve the new array to only the size that has values.
Sub kjlkj()
Dim arr(1 To 5) As String
arr(1) = "a"
arr(3) = "b"
arr(5) = "c"
Dim newArr() As String
ReDim newArr(1 To UBound(arr))
Dim j As Long
j = LBound(newArr)
Dim i As Long
For i = LBound(arr) To UBound(arr)
If arr(i) <> "" Then
newArr(j) = arr(i)
j = j + 1
End If
Next i
ReDim Preserve newArr(LBound(newArr) To j - 1)
'do what you want with the new array.
End Sub
Alternative via Filter() function
"However I would like to avoid creating new array."
A negative filtering allows a basically simple alternative, however you have to
declare your array dynamically (i.e. without preset number of elements) to allow a rebuild overwriting the original array,
execute a double replacement over the joined array elements to allow insertion of a unique character that can be filtered out.
Sub testFilter()
Dim arr() As String
ReDim arr(1 To 5)
arr(1) = "a"
arr(3) = "b"
arr(5) = "c"
'Debug.Print Join(arr, ",") ' ~~> a,,b,,c
'rearrange arr via RemoveEmpty()
arr = RemoveEmpty(arr) ' >> function RemoveEmpty()
Debug.Print Join(arr, ",") ' ~~> a,b,c
End Sub
Help function RemoveEmpty()
Adding an unused unique character, e.g. $, to the empty elements plus eventual negative filtering allows to remove these marked elements.
Note that the double replacement is necessary to allow to mark consecutive empty elements by the $ mark, as VBA would skip additional characters here.
Function RemoveEmpty(arr)
Dim tmp
tmp = Replace(Replace(Join(arr, "|"), "||", "|$|"), "||", "|$|")
RemoveEmpty = Filter(Split(tmp, "|"), "$", False)
End Function

Array not updating with values

I'm trying to run through a column of values, compare it to a supplied string, if it matches the string, add the value 4 columns over into an array, then sum the array at the end of the function.
The function exits out (not fails) at the ReDim Preserve line.
If I comment that out, it fails at the SumArray(Count) line.
What am I missing?
'Function used to SUM
Public Function TotalSum(prefix As String, rng As Range) As Integer
Dim BookofDaveSum As Dictionary
Set BookofDaveSum = New Dictionary
Dim SumArray As Variant
Dim Count As Long
Dim cell As Range
Dim i As Integer
Count = 0
For Each cell In rng
If Left(cell.Value, 7) = prefix Then
If Not BookofDaveSum.Exists(cell.Value2) Then
BookofDaveSum.Add cell.Value2, 0
ReDim Preserve SumArray(0 To Count)
SumArray(Count) = cell.Offset(0, 4)
Count = Count + 1
End If
End If
Next cell
TotalSum = Application.WorksheetFunction.Sum(SumArray)
End Function
Since you are iterating the range you are not gaining anything by using the array. Simply keep a running total:
Public Function TotalSum(prefix As String, rng As Range) As Integer
Dim BookofDaveSum As Dictionary
Set BookofDaveSum = New Dictionary
Dim cell As Range
For Each cell In rng
If Left(cell.Value, 7) = prefix Then
If Not BookofDaveSum.Exists(cell.Value2) Then
TotalSum = TotalSum + cell.Offset(0, 4).Value2
End If
End If
Next cell
End Function
If your concern is speed then convert both ranges to arrays and iterate the array:
Public Function TotalSum(prefix As String, rng As Range) As Long
Dim BookofDaveSum As Dictionary
Set BookofDaveSum = New Dictionary
Dim chRng As Variant
chRng = rng.Value2
Dim addRng As Variant
addRng = rng.Offset(, 4).Value2
Dim temp As Long
temp = 0
Dim i As Long
For i = LBound(chRng, 1) To UBound(chRng, 1)
If Left(chRng(i, 1), 7) = prefix Then
If Not BookofDaveSum.Exists(chRng(i, 1)) Then
temp = temp + addRng(i, 1)
End If
End If
Next cell
TotalSum = temp
End Function
Also this can be done with a formula:
=SUMPRODUCT(((LEFT(A1:A10,7)="abcdefg")*(E1:E10))/(COUNTIFS(A1:A10,A1:A10,A1:A10,"abcdefg" &"*")+(LEFT(A1:A10,7)<>"abcdefg")))
Where abcdefg is your prefix, A1:A10 is the string to test and E1:E10 the values to add
Dim SumArray() As Variant you are trying to redim a variable not an array. () indicates you want an array of variants.

Excel list an array in one row (without duplicate)

In Excel, I have an array from A1 to P30 filled with names. Some cells have the same name (duplicate).
Is there a formula possible to list all the content of this array in one single column (on another sheet)? This list must gather only unique name (no duplicate).
Thanks in advance.
Try this:
Function Unique(strRng As String) As Variant()
Dim Arr() As Variant
ReDim Arr(0)
Dim rng As Range
Dim c As Range
Dim Duplicated As Boolean
Dim i As Long
Dim j As Long
j = 0
Set rng = Range(strRng)
For Each c In rng.Cells
Duplicated = False
If c.Value <> vbNullString Then
For i = LBound(Arr) To UBound(Arr)
If c.Value = Arr(i) Then
Duplicated = True
Exit For
End If
Next i
If Not Duplicated Then
ReDim Preserve Arr(j)
Arr(j) = c.Value
j = j + 1
End If
End If
Next c
Unique = Arr
End Function 'Unique
Update
Seems you insist to using a function. Easy. Create a User Defined Function (UDF) as below:
Function Unique(rng As Range) As Variant()
Dim Arr() As Variant
ReDim Arr(0)
Dim c As Range
Dim Duplicated As Boolean
Dim i As Long
Dim j As Long
j = 0
For Each c In rng.Cells
Duplicated = False
If c.Value <> vbNullString Then
For i = LBound(Arr) To UBound(Arr)
If c.Value = Arr(i) Then
Duplicated = True
Exit For
End If
Next i
If Not Duplicated Then
ReDim Preserve Arr(j)
Arr(j) = c.Value
j = j + 1
End If
End If
Next c
Unique = Arr
' OR
'Unique = Application.Transpose(Arr) 'Use this when you want transpose your range from row to column or back.
End Function 'Unique
How to use the function?
Note that this is an array form function.
Write second code in VBA.
select the range you want to return your unique values. (In each sheet and each part of column)
Write =Unique(A1:P30) in formula bar and then press Ctrl + Shift + Enter from keyboard. (Dont press Enter only)
Now, you have a formula that return you unique values of a range as you said.
I prefer to use a Collection or Dictionary to check for duplicates.
In this example I use an ArrayList
Sub ProcessNames()
Dim v As Variant
Dim list As Object
Set list = CreateObject("System.Collections.ArrayList")
With Worksheets("Sheet1")
For Each v In .Range("A1:P30").Value
If Not list.Contains(v) Then list.Add v
End With
'1 Dimensional 0 Based Array which will span 1 Row
v = list.ToArray
'2 Dimensional 1 Based Array that will span 1 Column
v = WorksheetFunction.Transpose(v)
End Sub

VBA function that outputs all unique values on different cells in the same row in worksheet

I'm trying to create a function (that when you pass it an array (Maybe a range is better?) that it outputs all the unique values in the same row on different cells.
I've gotten as far as knowing how to identify the elements (which I don't think I've done right :( ) but I'm not sure how I'd output all the unique values. I only get the first one.
My code is as follows:
Function UniqueItems(ArrayIn, Optional Count As Variant) As Variant
' Accepts an array or range as input
' If Count = True or is missing, the function returns the number of unique elements
' If Count = False, the function returns a variant array of unique elements
Dim Unique() As Variant ' array that holds the unique items
Dim Element As Variant
Dim i As Integer
Dim FoundMatch As Boolean
'If 2nd argument is missing, assign default value
If IsMissing(Count) Then Count = True
' Counter for number of unique elements
NumUnique = 0
' Loop thru the input array
For Each Element In ArrayIn
FoundMatch = False
' Has item been added yet?
For i = 1 To NumUnique
If Element = Unique(i) Then
FoundMatch = True
Exit For '(exit loop)
End If
Next i
AddItem:
'If not in list, add the item to unique list
If Not FoundMatch And Not IsEmpty(Element) Then
NumUnique = NumUnique + 1
ReDim Preserve Unique(NumUnique)
Unique(NumUnique) = Element
End If
Next Element
If Count Then UniqueItems = NumUnique Else UniqueItems = Unique
Something like:
Function UniqueItems(ArrayIn) As Variant
Dim vData As Variant
Dim vNewdata() As Variant
Dim colUniques As Collection
Dim lCt As Long
If TypeName(ArrayIn) = "Range" Then
vData = ArrayIn.Value
Else
vData = ArrayIn
End If
Set colUniques = New Collection
'assuming a one-column range
On Error Resume Next 'ignore duplicates
For lCt = 1 To UBound(vData, 1)
colUniques.Add vData(lCt, 1), CStr(vData(lCt, 1))
Next
ReDim vNewdata(1 To 1, 1 To colUniques.Count)
For lCt = 1 To colUniques.Count
vNewdata(1, lCt) = colUniques(lCt)
Next
UniqueItems = vNewdata
End Function
you might use Scripting.dictionary to get unique value fast as for exemple
Sub TestArray()
Dim arrStart() As Variant
Dim oDic As Scripting.Dictionary
arr = Array(1, 1, 1, 2, 3, 4, 4, 5)
Set oDic = uniquevalue(arr)
'Note : put data into array
Dim arrResult() As Variant
arrResult = oDic.Keys
'Note : put data into string
Dim stringResult As String
stringResult = Join(oDic.Keys, ";")
End Sub
Function uniquevalue(ByVal myArray) As Scripting.Dictionary
'Note : Add REF DLL Microsoft Srcipting Runtime before !!
'Note : Option base =0 (standard vbe param)
'Note : Array is mono dimension of any data type
Dim oDic As Scripting.Dictionary
Set oDic = New Scripting.Dictionary
For i = LBound(myArray) To UBound(myArray)
If Not oDic.Exists(myArray(i)) Then oDic.Add myArray(i), oDic.Count
Next i
Set uniquevalue = oDic
End Function

Go through values in range, search for them in range, find value in respective rows, add them to array

I would like to go through a range of values in Column D and take each value:
for each value
check in the same range for its occurrence
check in the row of its occurrence for a value in column A
Add this value in column a to an array (or another way to save data)
go to the next occurrence of the value in column D and save the next Value of Column A to the array
When I checked each value for all its occurrences and added it to the array I want the array to be given out in the cell H1 (and for the next values onwards, I1 and so on)
Here's a picture of what I mean with some dummy values:
My attempts in VBA so far are this (with the remark that I deal with arrays for the first time):
Dim finden As String, FirstFound As String
Dim FoundCell As Range, rng As Range
Dim i As Integer
Dim zahl As Integer
Dim zeile As Range
Dim temparray As Double
Dim b As Integer
Dim count As Integer
Set rng = Worksheets("Tabelle1").Range("H1:H100")
i = Worksheets("Tabelle1").Cells(Rows.count, "D").End(xlUp).Row
For zahl = 1 To i
finden = Sheets("Tabelle1").Cells(zahl, "D").Value
count = Application.WorksheetFunction.CountIf(Range("A1:A100"), finden)
Set zeile = Sheets("Tabelle1").Columns("D").Find(finden, Cells(Rows.count, "D"), xlValues, xlWhole)
If Not zeile Is Nothing Then
FoundCell = zeile.Address
Do
For b = 1 To count
Set temparray(b, 1) = Sheets("Tabelle1").Cells(zeile.Row, "A").Value
Set zeile = Sheets("Tabelle1").Columns("A").Find(finden, zeile, xlValues, xlWhole)
Next b
Loop While zeile.Address <> FoundCell
End If
Set zeile = Nothing
rng.Value = temparray
Sheets("Tabelle1").Cells(1, 8 + zahl) = rng.Value
Next
End Sub
Unfortunately I already get a error message for:
set temparray(b,1)
telling me a data field was expected.
Any idea how I could solve my problem?
Have a look at the Collection object as it is a good way to store unique values. You don't need to run the multiple Find functions or incrementally build your array, you could simply read the columns once and write them into the relevant collection.
It's had to tell from your question and code how you want to write the output, but the code below will set you in the right direction:
Dim uniques As Collection
Dim valueSet As Collection
Dim valueD As String
Dim valueA As String
Dim v As Variant
Dim r As Long
Dim c As Long
Dim output() As String
'Read the data
With ThisWorkbook.Worksheets("Tabelle1")
v = .Range("A1", _
.Cells(Rows.Count, "D").End(xlUp)) _
.Value2
End With
'Populate the collections
Set uniques = New Collection
For r = 1 To UBound(v, 1)
valueA = CStr(v(r, 1))
valueD = CStr(v(r, 4))
'Check if we have a collection for the D value
Set valueSet = Nothing
On Error Resume Next
Set valueSet = uniques(valueD)
On Error GoTo 0
'If not then create a new one.
If valueSet Is Nothing Then
Set valueSet = New Collection
uniques.Add valueSet, Key:=valueD
End If
'Add the A value to it
valueSet.Add valueA
Next
'Compile the write array
ReDim Preserve output(1 To 1, 1 To uniques.Count)
c = 1
For Each valueSet In uniques
For Each v In valueSet
'--> uncomment this 'If block', if you want
'--> comma separated values.
' If Len(output(1, c)) > 0 Then
' output(1, c) = output(1, c) & ", "
' End If
output(1, c) = output(1, c) & v
Next
c = c + 1
Next
'Write the output array
ThisWorkbook.Worksheets("Tabelle1") _
.Range("H1").Resize(, UBound(output, 2)) _
.Value = output

Resources