i wanna have a reference on one element in a 2 dimensional Array like this:
dim ary(5,5) as String
ary(1) = "Michael, Thomas, Bill, Mike, Pascal"
ary(2) = "Iphone,HTCOne,SGS4,SGS3"
'... and so on
can i write sth like this:?
For i = 0 To UBound(ary)
activMan = ary(i)
Sheets("Example").Cells(1,1) = activMan(i)
'activMan is now Michael
' so i dont have to use two variables...
End If
Next i
' in the next round activMan is going to be HTCOne
Now activMan should be a reference on ary(i) in the first Dimension and i have access on all the elements in the second dimension.
Is that possilbe or completly wrong?
EDIT:
I'il give out:
1.: Mike -> arr(0,0)
2.: Ipod -> arr(1,1)
3.: .... -> arr(2,2)
But i realized it's possible with only one variable...^^
That is completely wrong :p
Analyse this bud :)
Option Explicit
Sub build2DArray()
' 2D 5 element array
' elements 1st 2nd 3rd 4th 5th
' index 0 [0, 0][1, 0][2, 0][3, 0][4, 0]
' index 1 [0, 1][1, 1][2, 1][3, 1][4, 1]
Dim arr(0 To 5, 0 To 1) as String ' same as Dim arr(5, 1)
arr(0, 0) = "Mike"
arr(1, 0) = "Tom"
arr(2, 0) = "Bill"
arr(3, 0) = "Michael"
arr(4, 0) = "Pascal"
arr(0, 1) = "IPhone"
arr(1, 1) = "Ipod"
arr(2, 1) = "Mac"
arr(3, 1) = "ITunes"
arr(4, 1) = "IArray"
Dim i As Long, j As Long
Dim activeMan As String
For i = LBound(arr) To UBound(arr) - 1
activeMan = arr(i, 0)
Debug.Print "loop no. " & i & " activeMan: " & activeMan
Cells(i + 1, 1).Value = activeMan
Cells(i + 1, 2).Value = arr(i, 1)
Next i
End Sub
Edit: its possible to use types and a custom function to achieve the same result, have a look
Private Type yourType
tName As String
tPhone As String
End Type
Sub example()
Dim yType(3) As yourType
yType(0).tName = "Michael"
yType(0).tPhone = "iPhone"
yType(1).tName = "Tom"
yType(1).tPhone = "Blackberry"
yType(2).tName = "Dave"
yType(2).tPhone = "Samsung"
Dim i&
For i = LBound(yType) To UBound(yType)
Debug.Print get_yType(yType, i)
Next i
End Sub
Private Function get_yType(arr() As yourType, i&) As String
get_yType = arr(i).tName & " " & arr(i).tPhone
End Function
Related
Using the below Boolean function to check if the cell value equals "M8D" or "M8P" or "M20")
Function m8_field(ByVal plf As String) As Boolean
m8_field = (plf = "M8D" Or plf = "M8P" Or plf = "M20")
End Function
And I use it like below and it works:
Dim arg As Range: Set arg = ActiveSheet.Range("D1:E20")
Dim arr: arr = arg.Value2
Dim r As Long
For r = 1 To UBound(arr)
If m8_field(arr(r, 2)) Then arr(r, 1) = "Good"
Next
What I need to change the last line :
If m8_field(arr(r, 2)) Then arr(r, 1) = "Good"
Into
If arr(r, 2) = m8_field Then arr(r, 1) = "Good"
But I got
Compile error:Argument not optional on this part (m8_field)
In advance any learning help will be appreciated
Flag When a String From a List Matches
If you would use a function, it would read the array of strings each time per row making it inefficient.
Sub m8_field_Sub()
Const GoodStringsList As String = "M8D,M8P,M20"
Dim GoodStrings() As String: GoodStrings = Split(GoodStringsList, ",")
Dim arg As Range: Set arg = ActiveSheet.Range("D1:E20")
Dim arr As Variant: arr = arg.Value2
Dim r As Long
For r = 1 To UBound(arr, 1)
If IsNumeric(Application.Match(CStr(arr(r, 2)), GoodStrings, 0)) Then
arr(r, 1) = "Good"
'Else
' arr(r, 1) = "Bad" ' or e.g. arr(r, 1) = ""
End If
Next
' Write back to the range.
'arg.Value = arr
End Sub
If you wanna get 'fancy' about it:
Function GetGoodStrings() As String()
Const GoodStringsList As String = "M8D,M8P,M20"
GetGoodStrings = Split(GoodStringsList, ",")
End Function
Function m8_field(ByVal plf As String, GoodStrings() As String) As Boolean
m8_field = IsNumeric(Application.Match(plf, GoodStrings, 0))
End Function
Sub TestTheFunctions()
' Read only once.
Dim GoodStrings() As String: GoodStrings = GetGoodStrings
Dim arg As Range: Set arg = ActiveSheet.Range("D1:E20")
Dim arr As Variant: arr = arg.Value2
Dim r As Long
Dim plf As String
For r = 1 To UBound(arr, 1)
plf = CStr(arr(r, 2))
If m8_field(plf, GoodStrings) Then ' needs parameters
arr(r, 1) = "Good"
'Else
' arr(r, 1) = "Bad" ' or e.g. arr(r, 1) = ""
End If
Next
' Write back to the range.
'arg.Value = arr
End Sub
Is there a way to have this script form the entire array based off the rows I want it to extract based on the IF Statement?
I know this finds a name on the Mgrs worksheet, and finds those rows in the Data worksheet, but then it directly prints it after forming the array. Can I have this code store all of the data, and then wait to print the data on a template that I format myself?
Option Explicit
Sub CIB_Cuts()
Dim j As Long, k As Long, x As Long
Dim varArray() As Variant
Dim varArray2() As Variant
ReDim varArray(1 To 19, 1 To 1)
Dim strManager As String, strEC As String, strLogin As String
Dim BASEPATH As String, strNewPath As String, strFileName As String
Dim Wb As Workbook
Dim mgrRow As Long
Dim colManager As Long
colManager = 3
Dim colLogin As Long
colLogin = 4
Dim colEC As Long
colEC = 5
BASEPATH = "M:\Final Files\"
Call speedupcode(True)
For mgrRow = 2 To ThisWorkbook.Worksheets("Mgrs").UsedRange.Rows.Count
If ThisWorkbook.Worksheets("Mgrs").Cells(mgrRow, 3) <> "" Then
strManager = ThisWorkbook.Worksheets("Mgrs").Cells(mgrRow, 3)
With ThisWorkbook.Worksheets("Data")
ReDim varArray(1 To UBound(varArray, 1), 1 To 1)
x = 1
For k = 1 To UBound(varArray, 1)
varArray(k, x) = .Cells(1, k)
Next
For j = 2 To .UsedRange.Rows.Count + 1
If strManager = .Cells(j, colManager) Then
x = x + 1
ReDim Preserve varArray(1 To UBound(varArray, 1), 1 To x)
For k = 1 To UBound(varArray, 1)
If k = 1 Then
varArray(1, x) = CStr(Format(.Cells(j, k), "000000000"))
Else
varArray(k, x) = .Cells(j, k)
End If
strEC = .Cells(j, colEC)
strManager = .Cells(j, colManager)
strLogin = .Cells(j, colLogin)
Next
End If
Next
End With
strFileName = strLogin & " - " & strManager & " - " & "Shift Differential Validation" & ".xlsx"
ReDim varArray2(1 To UBound(varArray, 2), 1 To UBound(varArray, 1))
Set Wb = Workbooks.Add(XlWBATemplate.xlWBATWorksheet)
With Wb
With .Worksheets("Sheet1")
.Columns(1).NumberFormat = "#"
.Columns(15).NumberFormat = "0%"
For j = 1 To UBound(varArray, 2)
For k = 1 To UBound(varArray, 1)
varArray2(j, k) = varArray(k, j)
Next
Next
.Range(.Cells(1, 1), .Cells(UBound(varArray, 2), UBound(varArray, 1))) = varArray2
Call DataValidation
Call Header
.Range("C2").Select
ActiveWindow.FreezePanes = True
.Cells.EntireColumn.AutoFit
.Rows("1:1").Font.Bold = True
Call protect
End With
.SaveAs strNewPath & strFileName, Password:="password", FileFormat:=51
.Saved = True
.Close
End With
Set Wb = Nothing
End If
Next
Call speedupcode(False)
End Sub
You could store the array each time in an overarching array or a collection and loop that at the end...
Public Sub test()
Dim varArray2() As Variant, results As Collection
'other code..
Set results = New Collection
results.Add varArray2
End Sub
You could also use Select Case , or something distinctive during the loop, to determine a key and populate a dictionary with the arrays as values which might make retrieval of specific items easier.
first of all, i'd like to say, i've sarched thorugh the net, but i haven't run into such a thing. i've seen collection of collections, or array of arrays, but not a collection of array.
what i want to do is, to collect ID's in collections for each District. Finally, i will join the values in the collections with Join function and ";" as delimiter, and then print them in a range of 4 column as a lookup list, for each class. For example;
Class2(0) will include 54020 and 30734, class2(1) will include 58618, class1(4) will include none, class3(7) will include 35516,34781 and 56874, and so on.
i want to loop through column C and put a select case statment to check the class and then assign the values to collections
Sub dict_coll()
Dim class1() As New Collection
Dim class2() As New Collection
Dim class3() As New Collection
Dim class4() As New Collection
Dim dict As New Scripting.Dictionary
Set dRange = range(range("a2"), range("a2").End(xlDown))
i = 0
For Each d In dRange
If Not dict.Exists(d.Value) Then
dict.Add key:=d.Value, item:=i
i = i + 1
End If
Next d
Set cRange = range(range("c2"), range("c2").End(xlDown))
For Each c In cRange
Select Case c.Value
Case "class1"
class1(dict(c.offset(0,-2).value)).Add c.Offset(0, 1).Value 'fails here
Case "class2"
class2(dict(c.offset(0,-2).value)).Add c.Offset(0, 1).Value 'fails here
Case "class3"
class3(dict(c.offset(0,-2).value)).Add c.Offset(0, 1).Value 'fails here
Case Else
class4(dict(c.offset(0,-2).value)).Add c.Offset(0, 1).Value 'fails here
End Select
Next c
End Sub
and what i want to see is as foloowing:
is there any easier and proper way of what i wanna do? any help wil be appreciated.
thanks
I didnt see that sb variable defined in your code.
Anyway, for me I see a case of straightforward arrays: There is fixed dimension of classes so it good enough for me. Furthermore, you can print back to worksheet so easily.
Public Sub test()
Const strPrefix = "class"
Dim districtRange As Range, outputRange As Range, r As Range
Dim arr() As String
Dim i As Long, j As Long, x As Long, y As Long
Dim district As String, str As String, idVal As String
Dim arr2 As Variant
Application.ScreenUpdating = False
ReDim arr(1 To 5, 1 To 1)
arr(1, 1) = "District"
arr(2, 1) = "Class 1"
arr(3, 1) = "Class 2"
arr(4, 1) = "Class 3"
arr(5, 1) = "Class 4"
Set districtRange = Range(Range("A2"), Range("C2").End(xlDown))
arr2 = districtRange.Value
For x = LBound(arr2, 1) To UBound(arr2, 1)
district = arr2(x, 1)
i = Val(Mid(arr2(x, 3), Len(strPrefix) + 1))
idVal = arr2(x, 2)
j = inArray(arr, district, 1) 'returns -1 if not found
If j >= 0 Then
arr(i + 1, j) = IIf(arr(i + 1, j) = "", idVal, arr(i + 1, j) & ";" & idVal)
Else
ReDim Preserve arr(1 To 5, 1 To UBound(arr, 2) + 1)
arr(1, UBound(arr, 2)) = district
arr(i + 1, UBound(arr, 2)) = idVal
End If
Next x
Set outputRange = Range("E1")
outputRange.Resize(UBound(arr, 2), UBound(arr, 1)).Value = Application.Transpose(arr)
outputRange.Sort Key1:=Range("E1"), Header:=xlYes, Order1:=xlAscending
Application.ScreenUpdating = True
End Sub
Public Function inArray(arr As Variant, k As String, Optional rowNum As Long, Optional colNum As Long) As Long
Dim i As Long, j As Long
inArray = -1
If rowNum Then
For i = LBound(arr, 2) To UBound(arr, 2)
If arr(rowNum, i) = k Then
inArray = i
Exit Function
End If
Next i
Else
For i = LBound(arr, 1) To UBound(arr, 1)
If arr(i, colNum) = k Then
inArray = i
Exit Function
End If
Next i
End If
End Function
by the way, i've found another solution, usinf both dictionary and 3-dimension array.
Sub test()
Dim Blg As New Scripting.Dictionary
Dim Sgm As New Scripting.Dictionary
Dim Siciller() As String
ReDim Siciller(0 To 23, 0 To 3, 0 To 5)
Set alanBolge = range(range("a2"), range("a2").End(xlDown))
Set alanSegment = range(range("c2"), range("c2").End(xlDown))
i = 0
For Each d In alanBolge
If Not Blg.Exists(d.Value) Then
Blg.Add Key:=d.Value, item:=i
i = i + 1
End If
Next d
k = 0
For Each d In alanSegment
If Not Sgm.Exists(d.Value) Then
Sgm.Add Key:=d.Value, item:=k
k = k + 1
End If
Next d
'data reading
For Each d In alanBolge
Siciller(Blg(d.Value), Sgm(d.Offset(0, 2).Value), dolusay(Siciller, Blg(d.Value), Sgm(d.Offset(0, 2).Value)) + 1) = d.Offset(0, 1).Value
Next d
'output
For x = 1 To 4
For y = 1 To 24
Set h = Cells(1 + y, 5 + x)
h.Select
h.Value = sonucgetir(Siciller, Blg(h.Offset(0, -x).Value), Sgm(h.Offset(-y, 0).Value))
Next y
Next x
End Sub
Public Function dolusay(ByVal data As Variant, ByVal i1 As Integer, ByVal i2 As Integer) As Integer
Dim count As Integer
count = 0
For j = 0 To UBound(data, 3) - 1
If Len(data(i1, i2, j)) > 0 Then
count = count + 1
End If
Next
dolusay = count
End Function
Public Function sonucgetir(ByVal data As Variant, ByVal i1 As Integer, ByVal i2 As Integer) As String
sonucgetir = ""
For i = 0 To UBound(data, 3)
If Len(data(i1, i2, i)) > 0 Then
x = data(i1, i2, i) & ";" & x
sonucgetir = Left(x, Len(x) - 1)
End If
Next i
End Function
Ubound can return the max index value of an array, but in a multidimensional array, how would I specify WHICH dimension I want the max index of?
For example
Dim arr(1 to 4, 1 to 3) As Variant
In this 4x3 array, how would I have Ubound return 4, and how would I have Ubound return 3?
ubound(arr, 1)
and
ubound(arr, 2)
You need to deal with the optional Rank parameter of UBound.
Dim arr(1 To 4, 1 To 3) As Variant
Debug.Print UBound(arr, 1) '◄ returns 4
Debug.Print UBound(arr, 2) '◄ returns 3
More at: UBound Function (Visual Basic)
[This is a late answer addressing the title of the question (since that is what people would encounter when searching) rather than the specifics of OP's question which has already been answered adequately]
Ubound is a bit fragile in that it provides no way to know how many dimensions an array has. You can use error trapping to determine the full layout of an array. The following returns a collection of arrays, one for each dimension. The count property can be used to determine the number of dimensions and their lower and upper bounds can be extracted as needed:
Function Bounds(A As Variant) As Collection
Dim C As New Collection
Dim v As Variant, i As Long
On Error GoTo exit_function
i = 1
Do While True
v = Array(LBound(A, i), UBound(A, i))
C.Add v
i = i + 1
Loop
exit_function:
Set Bounds = C
End Function
Used like this:
Sub test()
Dim i As Long
Dim A(1 To 10, 1 To 5, 4 To 10) As Integer
Dim B(1 To 5) As Variant
Dim C As Variant
Dim sizes As Collection
Set sizes = Bounds(A)
Debug.Print "A has " & sizes.Count & " dimensions:"
For i = 1 To sizes.Count
Debug.Print sizes(i)(0) & " to " & sizes(i)(1)
Next i
Set sizes = Bounds(B)
Debug.Print vbCrLf & "B has " & sizes.Count & " dimensions:"
For i = 1 To sizes.Count
Debug.Print sizes(i)(0) & " to " & sizes(i)(1)
Next i
Set sizes = Bounds(C)
Debug.Print vbCrLf & "C has " & sizes.Count & " dimensions:"
For i = 1 To sizes.Count
Debug.Print sizes(i)(0) & " to " & sizes(i)(1)
Next i
End Sub
Output:
A has 3 dimensions:
1 to 10
1 to 5
4 to 10
B has 1 dimensions:
1 to 5
C has 0 dimensions:
UBound(myArray, 1) returns the number of rows in 2d array
UBound(myArray, 2) returns the number of columns in 2d array
However, let's go 1 step further and assume that you need the last row and last column of range, that has been written as a 2d array. That row (or column) should be converted to a 1d array. E.g. if our 2d array looks like this:
Then running the code below, will give you 2 1D arrays, that are the last column and last row:
Sub PrintMultidimensionalArrayExample()
Dim myRange As Range: Set myRange = Range("a1").CurrentRegion
Dim myArray As Variant: myArray = myRange
Dim lastRowArray As Variant: lastRowArray = GetRowFromMdArray(myArray, UBound(myArray, 1))
Dim lastColumnArray As Variant
lastColumnArray = GetColumnFromMdArray(myArray, UBound(myArray, 2))
End Sub
Function GetColumnFromMdArray(myArray As Variant, myCol As Long) As Variant
'returning a column from multidimensional array
'the returned array is 0-based, but the 0th element is Empty.
Dim i As Long
Dim result As Variant
Dim size As Long: size = UBound(myArray, 1)
ReDim result(size)
For i = LBound(myArray, 1) To UBound(myArray, 1)
result(i) = myArray(i, myCol)
Next
GetColumnFromMdArray = result
End Function
Function GetRowFromMdArray(myArray As Variant, myRow As Long) As Variant
'returning a row from multidimensional array
'the returned array is 0-based, but the 0th element is Empty.
Dim i As Long
Dim result As Variant
Dim size As Long: size = UBound(myArray, 2)
ReDim result(size)
For i = LBound(myArray, 2) To UBound(myArray, 2)
result(i) = myArray(myRow, i)
Next
GetRowFromMdArray = result
End Function
In addition to the already excellent answers, also consider this function to retrieve both the number of dimensions and their bounds, which is similar to John's answer, but works and looks a little differently:
Function sizeOfArray(arr As Variant) As String
Dim str As String
Dim numDim As Integer
numDim = NumberOfArrayDimensions(arr)
str = "Array"
For i = 1 To numDim
str = str & "(" & LBound(arr, i) & " To " & UBound(arr, i)
If Not i = numDim Then
str = str & ", "
Else
str = str & ")"
End If
Next i
sizeOfArray = str
End Function
Private Function NumberOfArrayDimensions(arr As Variant) As Integer
' By Chip Pearson
' http://www.cpearson.com/excel/vbaarrays.htm
Dim Ndx As Integer
Dim Res As Integer
On Error Resume Next
' Loop, increasing the dimension index Ndx, until an error occurs.
' An error will occur when Ndx exceeds the number of dimension
' in the array. Return Ndx - 1.
Do
Ndx = Ndx + 1
Res = UBound(arr, Ndx)
Loop Until Err.Number <> 0
NumberOfArrayDimensions = Ndx - 1
End Function
Example usage:
Sub arrSizeTester()
Dim arr(1 To 2, 3 To 22, 2 To 9, 12 To 18) As Variant
Debug.Print sizeOfArray(arr())
End Sub
And its output:
Array(1 To 2, 3 To 22, 2 To 9, 12 To 18)
Looping D3 ways;
Sub SearchArray()
Dim arr(3, 2) As Variant
arr(0, 0) = "A"
arr(0, 1) = "1"
arr(0, 2) = "w"
arr(1, 0) = "B"
arr(1, 1) = "2"
arr(1, 2) = "x"
arr(2, 0) = "C"
arr(2, 1) = "3"
arr(2, 2) = "y"
arr(3, 0) = "D"
arr(3, 1) = "4"
arr(3, 2) = "z"
Debug.Print "Loop Dimension 1"
For i = 0 To UBound(arr, 1)
Debug.Print "arr(" & i & ", 0) is " & arr(i, 0)
Next i
Debug.Print ""
Debug.Print "Loop Dimension 2"
For j = 0 To UBound(arr, 2)
Debug.Print "arr(0, " & j & ") is " & arr(0, j)
Next j
Debug.Print ""
Debug.Print "Loop Dimension 1 and 2"
For i = 0 To UBound(arr, 1)
For j = 0 To UBound(arr, 2)
Debug.Print "arr(" & i & ", " & j & ") is " & arr(i, j)
Next j
Next i
Debug.Print ""
End Sub
I am creating a search function that allows users to search up to 3 different properties at the same time in a database (prop1,2 and 3) and I have created this sub in VBA by putting the results for a searched prop into an array. However, now that I have up to 3 arrays I need to consolidate the arrays so that only the data that is duplicated in the arrays are displayed in the results. Is there any advice on how to 1) only look at the arrays for the properties that the user is searching for and 2) take only the data that is repeated into a final array so I can display it in a results range? Any help is greatly appreciated! Thanks!
Assuming that your entries are directly from a database and therefore are unique for one property, I can think of following steps for a simple solution:
Merge Arrays together (prop1, prop2, prop3 > temp)
Count occurrences for each element (in this example code tempCount)
Based on the knowledge about the occurrences, create the final array (here called result)
Dim prop1() As Variant
Dim prop2() As Variant
Dim prop3() As Variant
Dim temp() As Variant
Dim tempCount() As Integer
Dim result() As Variant
ReDim temp(UBound(prop1) + UBound(prop2) + UBound(prop3) + 1)
'merge arrays
Dim i As Integer
On Error Resume Next
For i = 0 To UBound(temp)
temp(i * 3) = prop1(i)
temp(i * 3 + 1) = prop2(i)
temp(i * 3 + 2) = prop3(i)
Next i
'count occurences
ReDim tempCount(UBound(temp) + 1)
Dim j As Integer
For i = 0 To UBound(temp)
tempCount(i) = 1
For j = 0 To i - 1
'comparison of elements
If temp(i) = temp(j) Then
tempCount(i) = tempCount(i) + 1
End If
Next j
Next i
ReDim result(UBound(temp) + 1)
'if an element occurs 3 times, add it to result
Dim count As Integer
count = 0
For i = 0 To UBound(tempCount)
If tempCount(i) = 3 Then
result(count) = temp(i)
count = count + 1
End If
Next i
To check for some samples I added this to the code. It simply prints out the arrays temp, result and tempCount to the columns A, B and C.
'some sample arrays
prop1 = Array("a", "b", "c", "d", "e")
prop2 = Array("b", "c", "f")
prop3 = Array("b", "c", "d", "g")
'some sample Output
'temp
Cells(1, 1).Value = "temp:"
For i = 0 To UBound(temp)
Cells(i + 2, 1).Value = temp(i)
Next i
'result
Cells(1, 2).Value = "result:"
For i = 0 To UBound(result)
Cells(i + 2, 2).Value = result(i)
Next i
'count:
Cells(1, 3).Value = "count:"
For i = 0 To UBound(tempCount)
Cells(i + 2, 3).Value = tempCount(i)
Next i
Notes: tempCount just holds the cumulative number of occurrences at the point the element is watched at.