I am trying to assign a two-dimensional Variant array to a variable, which for some reason doesn't work.
Function getClusters() As Variant()
Dim numberOfClusters, numberOfDifferentPartsPlusCaption, i, k As Integer
Dim clusters_() As Variant
numberOfClusters = Worksheets("Cluster Definition xy").UsedRange.Columns(Worksheets("Cluster Definition xy").UsedRange.Columns.Count).column - 1
numberOfDifferentPartsPlusCaption = Worksheets("Cluster Definition xy").UsedRange.Rows(Worksheets("Cluster Definition xy").UsedRange.Rows.Count).Row - 4
ReDim clusters_(numberOfClusters - 1, numberOfDifferentPartsPlusCaption)
For i = 0 To numberOfClusters - 1
clusters_(i, 0) = Worksheets("Cluster Definition xy").Cells(3, i + 2)
For k = 1 To numberOfDifferentPartsPlusCaption
clusters_(i, k) = Worksheets("Cluster Definition xy").Cells(k + 4, i + 2)
Next
Next
getClusters = clusters_
'WriteArrayToImmediateWindow (getClusters)
End Function
The function is called when initializing a userform and should work just fine, the result looks like this:
Array screenshot
The error occurs in the line "clusters = getClusters()" and indicates a type mismatch.
Private Sub UserForm_Initialize()
Dim clusters() as Variant
Dim numberOfClusters, i As Integer
'ReDim clusters(UBound(getClusters(), 1) - LBound(getClusters(), 1), UBound(getClusters(), 2) - LBound(getClusters(), 2))
clusters = getClusters()
numberOfClusters = UBound(clusters, 1) - LBound(clusters, 1) + 1
For i = 0 To numberOfClusters
something
Next
End Sub
What am I doing wrong? I'm afraid I'm missing something extremely basic here.
Thanks a lot in advance!
Related
If I want to create a random order to select another pair from my image. , not repeating the random pair i've previously picked, i.e. so that once i've gone through 56 random unique images i.e. 26 random pairs, the game is over, and reset to my original 57 images and start picking random pairs again. Can this be done in VBA Powerpoint?
This is the sub I am using:
Sub RandomImage()
Dim i As Long
Dim posLeft As Long
For i = 1 To 2
Randomize
RanNum% = Int(57 * Rnd) + 1
Path$ = ActivePresentation.Path
FullFileName$ = Path$ + "/" + CStr(RanNum%) + ".png"
posLeft = 50 + ((i - 1) * 400)
Call ActivePresentation.Slides(1).Shapes.AddPicture(FileName:=FullFileName$, LinkToFile:=msoTrue, SaveWithDocument:=msoTrue, Left:=posLeft, Top:=100, Width:=400)
Next
End Sub
Please, try the next function. It uses an array built from 1 to maximum necessary/existing number. It returns the RND array element and then eliminate it from the array, next time returning from the remained elements:
Please, copy the next variables on top of the module keeping the code you use (in the declarations area):
Private arrNo
Private Const maxNo As Long = 57 'maximum number of existing pictures
Copy the next function code in the same module:
Function ReturnUniqueRndNo() As Long
Dim rndNo As Long, filt As String, arr1Based, i As Long
If Not IsArray(arrNo) Then
ReDim arrNo(maxNo - 1)
For i = 0 To UBound(arrNo): arrNo(i) = i + 1: Next i
End If
If UBound(arrNo) = 0 Then
ReturnUniqueRndNo = arrNo(0)
ReDim arrNo(maxNo - 1)
For i = 0 To UBound(arrNo): arrNo(i) = i + 1: Next i
MsgBox "Reset the used array..."
Exit Function
End If
Randomize
rndNo = Int((UBound(arrNo) - LBound(arrNo) + 1) * Rnd + LBound(arrNo))
ReturnUniqueRndNo = arrNo(rndNo) 'return the array element
filt = arrNo(rndNo) & "$$$": arrNo(rndNo) = filt 'transform the array elem to be removed
arrNo = filter(arrNo, filt, False) 'eliminate the consumed number, but returning a 0 based array...
End Function
The used array is reset when reaches its limit and send a message.
It may be tested using the next testing Sub:
Sub testReturnUniqueRndNo()
Dim uniqueNo As Long, i As Long
For i = 1 To 2
uniqueNo = ReturnUniqueRndNo
Debug.Print uniqueNo
Next i
End Sub
In order to test it faster, you may modify maxNo at 20...
After testing it, you have to modify your code in the next way:
Sub RandomImage()
Dim i As Long, posLeft As Long, RanNum%, path$, fullFileName$
path = ActivePresentation.path
For i = 1 To 2
RanNum = ReturnUniqueRndNo
fullFileName = path + "/" + CStr(RanNum) + ".png"
posLeft = 50 + ((i - 1) * 400)
Call ActivePresentation.Slides(1).Shapes.AddPicture(fileName:=fullFileName, _
LinkToFile:=msoTrue, SaveWithDocument:=msoTrue, left:=posLeft, top:=100, width:=400)
Next
End Sub
Please, test it and send some feedback. I did not test it in Access, but it should work...
I am wondering if VBA can return more than 1 array in a function. I have created a function called 'getStats()' and i would like to return 2 arrays named 'returnVal' and 'a' as shown below. I have tried the methods below but i only get back the value for array 'a' which is 10. It does'nt give me the array for 'returnVal'. Is there any way to do that? Pls help. I tried doing this: "getStats = returnVal & a " but an error occured as type mismatch
Sub mysub()
Dim i As Integer
Dim myArray() As Integer
myArray() = getStats() 'calling for function
MsgBox myArray(0)
MsgBox myArray(1)
MsgBox myArray(2)
End Sub
Function getStats() As Integer()
Dim returnVal(1 To 2) As Integer
Dim a(0) As Integer
returnVal(1) = 7
returnVal(2) = 8
a(0) = 5 + 5
getStats = returnVal 'returning value
getStats = a 'returning value
End Function
A Function procedure can return one single result.
You can make that result a Variant and return an array of arrays or a custom object that encapsulates two arrays, but no matter what you do the function returns one value of the type you specify as its return type in its signature.
Or you can take ByRef parameters - this should work (untested):
Public Sub GimmeTwoArrays(ByRef outArray1 As Variant, ByRef outArray2 As Variant)
ReDim outArray1(1 To 10)
ReDim outArray2(1 To 10)
Dim i As Long
For i = 1 To 10
outArray1(i) = i
outArray2(i) = Chr$(64 + i)
Next
End Sub
The caller only needs to pass the variant pointers, doesn't matter if you initialize them or not:
Dim values1 As Variant
Dim values2 As Variant
GimmeTwoArrays values1, values2
Debug.Print values1(1), values2(1)
You don't have to declare them As Variant, but wrapping your arrays in a Variant generally makes them easier to pass around and work with.
Return function results as ParamArray contents
In addition to Mathieu's valid answer referring to an array of arrays (or jagged array), I demonstrate a way to get the function results as ParamArray contents passed as empty array arguments. The function result assigned to arr has the possible advantage to dispose of several ways to address the individual or entire array contents:
get the whole set (e.g. array name arr) conform to ParamArray structure
get the sub sets directly, even by the original array names (here a and b)
Sub ExampleCall()
'[0] declare empty arrays and assign array to function results via ParamArray argument
Dim arr, a(1 To 10), b(1 To 10)
arr = GetBoth(a, b) ' << function GetBoth()
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'Two options to display results:
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'[1] get the whole set conform to ParamArray structure
' shows: arr(0) ~> 1,2,3,4,5,6,7,8,9,10 arr(1) ~> A,B,C,D,E,F,G,H,I,J
Debug.Print "arr(0) ~> " & Join(arr(0), ","), _
"arr(1) ~> " & Join(arr(1), ",")
'[2] get the sub sets directly, even by the original array names
' shows: a ~> 1|2|3|4|5|6|7|8|9|10 b ~> A|B|C|D|E|F|G|H|I|J
Debug.Print "a ~> " & Join(a, "|"), _
"b ~> " & Join(b, "|")
'[ad) 1/2] get individual values, e.g. the first item of the second array
' note that sub sets a and b got a 1-base declaration here,
' whereas the array of the subset arrays remains 0-based
Debug.Print "arr(1)(2) = " & arr(1)(2) ' // shows: arr(1)(2) = B
Debug.Print "b(2) = " & b(2) ' // shows: b(2) = B
End Sub
Function GetBoth() via ParamArray arguments
Function GetBoth(ParamArray arr()) As Variant
Dim i As Long
For i = 1 To 10
arr(0)(i) = i
arr(1)(i) = Chr$(64 + i)
Next
GetBoth = arr
End Function
Inspired by Mathieu and T.M, this function creates an arbitrary number of variables, and deals out a deck of cards.
Sub PlayHand()
Dim Huey(0 To 4), Dewey(0 To 4), Louie(0 To 4)
DealCards Huey, Dewey, Louie
Dim Charlotte(0 To 6), Anne(0 To 6), Elizabeth(0 To 6), Maria(0 To 6)
Combined = DealCards(Charlotte, Anne, Elizabeth, Maria)
End Sub
Function DealCards(ParamArray Players())
'Create deck of cards
Set cardCollection = New Collection
For Each suit In Array("H", "C", "S", "D")
For Each rank In Array(2, 3, 4, 5, 6, 7, 8, 9, 10, "J", "Q", "K", "A")
cardCollection.Add suit & "_" & Rank
Next
Next
'Deal out the cards to each player
For i = 0 To UBound(Players)
For j = 0 To UBound(Players(i))
randomCard = Round(Rnd() * cardCollection.Count + 0.5, 0)
Players(i)(j) = cardCollection(randomCard)
cardCollection.Remove randomCard
Next
Next
DealHand = Players
End Function
Merge Two Long Arrays
Option Explicit
Sub mysub()
Dim i As Long
Dim myArray() As Long
myArray() = getStats() 'calling for function
For i = LBound(myArray) To UBound(myArray)
Debug.Print myArray(i)
' MsgBox myArray(i)
Next i
End Sub
Function getStats() As Long()
Dim returnVal(1 To 2) As Long
Dim a(0) As Long
returnVal(1) = 7
returnVal(2) = 8
a(0) = 5 + 5
getStats = mergeTwoLongArrays(returnVal, a)
End Function
Function mergeTwoLongArrays(Array1, Array2, Optional Base As Long = 0)
Dim arr() As Long
Dim NoE As Long
Dim countNew As Long
NoE = UBound(Array1) - LBound(Array1) + UBound(Array2) - UBound(Array2) + 2
ReDim arr(Base To NoE - Base - 1)
countNew = LBound(arr)
For NoE = LBound(Array1) To UBound(Array1)
arr(countNew) = Array1(NoE)
countNew = countNew + 1
Next NoE
For NoE = LBound(Array2) To UBound(Array2)
arr(countNew) = Array2(NoE)
countNew = countNew + 1
Next NoE
mergeTwoLongArrays = arr
End Function
Right, so using Python I would create a multidimensional list and set the values on one line of code (as per the below).
aryTitle = [["Desciption", "Value"],["Description2", "Value2"]]
print(aryTitle[0,0] + aryTitle[0,1])
I like the way I can set the values on one line. In VBA I am doing this by:
Dim aryTitle(0 To 1, 0 To 1) As String
aryTitle(0, 0) = "Description"
aryTitle(0, 1) = "Value"
aryTitle(1, 0) = "Description2"
aryTitle(1, 1) = "Value2"
MsgBox (aryTitle(0, 0) & aryTitle(0, 1))
Is there a way to set the values in one line of code?
Not natively, no. But you can write a function for it. The only reason Python can do that is someone wrote a function to do it. The difference is that they had access to the source so they could make the syntax whatever they like. You'll be limited to VBA function syntax. Here's a function to create a 2-dim array. It's not technically 'one line of code', but throw it in your MUtilities module and forget about it and it will feel like one line of code.
Public Function FillTwoDim(ParamArray KeyValue() As Variant) As Variant
Dim aReturn() As Variant
Dim i As Long
Dim lCnt As Long
ReDim aReturn(0 To ((UBound(KeyValue) + 1) \ 2) - 1, 0 To 1)
For i = LBound(KeyValue) To UBound(KeyValue) Step 2
If i + 1 <= UBound(KeyValue) Then
aReturn(lCnt, 0) = KeyValue(i)
aReturn(lCnt, 1) = KeyValue(i + 1)
lCnt = lCnt + 1
End If
Next i
FillTwoDim = aReturn
End Function
Sub test()
Dim vaArr As Variant
Dim i As Long
Dim j As Long
vaArr = FillTwoDim("Description", "Value", "Description2", "Value2")
For i = LBound(vaArr, 1) To UBound(vaArr, 1)
For j = LBound(vaArr, 2) To UBound(vaArr, 2)
Debug.Print i, j, vaArr(i, j)
Next j
Next i
End Sub
If you supply an odd number of arguments, it ignores the last one. If you use 3-dim arrays, you could write a function for that. You could also write a fancy function that could handle any dims, but I'm not sure it's worth it. And if you're using more than 3-dim arrays, you probably don't need my help writing a function.
The output from the above
0 0 Description
0 1 Value
1 0 Description2
1 1 Value2
You can write a helper function:
Function MultiSplit(s As String, Optional delim1 As String = ",", Optional delim2 As String = ";") As Variant
Dim V As Variant, W As Variant, A As Variant
Dim i As Long, j As Long, m As Long, n As Long
V = Split(s, delim2)
m = UBound(V)
n = UBound(Split(V(0), delim1))
ReDim A(0 To m, 0 To n)
For i = 0 To m
For j = 0 To n
W = Split(V(i), delim1)
A(i, j) = Trim(W(j))
Next j
Next i
MultiSplit = A
End Function
Used like this:
Sub test()
Dim A As Variant
A = MultiSplit("Desciption, Value; Description2, Value2")
Range("A1:B2").Value = A
End Sub
I added two vb files to a new vs project and I seem to be having a problem with the last line of the code below. I get an error: Operator '*' is not defined for types 'Char' and 'String'.
I don't know too much about vb so can someone explain to me whats going on in this last line and how I may fix the error? mStream is a FileStream
Public Shared Function GetCharImage(Font As Integer, c As Char) As Bitmap
If UnicodeFonts.mStream Is Nothing Then
UnicodeFonts.Init()
End If
' The following expression was wrapped in a checked-statement
UnicodeFonts.mStream = UnicodeFonts.Stream(Font - 1)
UnicodeFonts.mReader = UnicodeFonts.Reader(Font - 1)
' The following expression was wrapped in a checked-expression
UnicodeFonts.mStream.Seek(CLng(c * ""), 0)
Edit ***
the line that calls the above method is this:
array(i - 1) = UnicodeFonts.GetCharImage(Font, CharType.FromString(Strings.Mid(Text, i)))
from the following method:
Public Shared Function GetStringImage(Font As Integer, Text As String) As Bitmap
' The following expression was wrapped in a checked-statement
Dim array As Bitmap() = New Bitmap(Strings.Len(Text) - 1 + 1 - 1) {}
Dim arg_19_0 As Integer = 1
Dim num As Integer = Strings.Len(Text)
Dim num2 As Integer
Dim height As Integer
For i As Integer = arg_19_0 To num
array(i - 1) = UnicodeFonts.GetCharImage(Font, CharType.FromString(Strings.Mid(Text, i)))
num2 += array(i - 1).Width
If array(i - 1).Height > height Then
height = array(i - 1).Height
End If
Next
Dim bitmap As Bitmap = New Bitmap(num2, height, PixelFormat.Format32bppArgb)
Dim graphics As Graphics = Graphics.FromImage(bitmap)
Dim arg_8C_0 As Integer = 1
Dim num3 As Integer = Strings.Len(Text)
For j As Integer = arg_8C_0 To num3
Dim num4 As Integer
graphics.DrawImage(array(j - 1), num4, 0)
num4 += array(j - 1).Width
Next
Dim arg_C4_0 As Integer = 1
Dim num5 As Integer = Strings.Len(Text)
For k As Integer = arg_C4_0 To num5
array(k - 1).Dispose()
Next
graphics.Dispose()
Return bitmap
End Function
The code is working with a file containing fonts.
My best guess is that you're trying to find the data for a font character at a specific offset within a file, based on the character code.
You could try something like:
UnicodeFonts.mStream.Seek(CLng(c) * 4), 0)
I've chosen 4 here, on the assumption whatever you're looking for is in a table of 4-byte integers.
The change here is that I'm converting c to a number using CLng(c) first, then multiplying this by another number, instead of a string.
The problem is that you are trying to multiply a character and a string: c * "" Characters and strings are not numbers, so they cannot be multiplied together.
I have a two-dimensional array:
(1, 1) = X (1, 2) = [Empty] (1, 3) = [Empty]
(2, 1) = Y (2, 2) = [Empty] (2, 3) = [Empty]
(3, 1) = Z (3, 2) = [Empty] (3, 3) = [Empty]
I want to store data in 2nd and 3rd column, where the row number is determined by matching values in the first column against some specific value provided. Is there a way to find the row number of the array where Z is present, without having to loop through the whole column? I'm looking for an equivalent of using WorksheetFunction.Match on a one-dimensional array.
To solve my problem, I can create two arrays, where the first one will have one dimension and will store values to look in, and the second one will store the rest of columns. I'd rather have just one, though.
You can use Index() for working with areas in arrays which then allows you to use match. However, I've always found Excel functions to be extremely slow when used on VBA arrays, especially on larger ones.
I'd hazard a guess and and say that actually looping through would be your best bet here. Alternatively, depending on your use case use a different storage mechanism, something with a Key/Value lookup like a collection or Scripting.Dictionary would probably give you the best performance
EDIT
For the record, I again state that I wouldn't do it like this, it's slow on large arrays, but you can do:
Sub test()
Dim arr(1 To 3, 1 To 3)
arr(1, 1) = "X"
arr(2, 1) = "Y"
arr(3, 1) = "Z"
With Application
MsgBox .Match("Z", .Index(arr, 0, 1), 0)
End With
End Sub
Try this function
Public Function posInArray(ByVal itemSearched As Variant,ByVal aArray As Variant) As Long
Dim pos As Long, item As Variant
posInArray = 0
If IsArray(aArray) Then
If Not isEmpty(aArray) Then
pos = 1
For Each item In aArray
If itemSearched = item Then
posInArray = pos
Exit Function
End If
pos = pos + 1
Next item
posInArray = 0
End If
End If
End Function
'To determine if a multi-dimension array is allocated (or empty)
'Works for any-dimension arrays, even one-dimension arrays
Public Function isArrayAllocated(ByVal aArray As Variant) As Boolean
On Error Resume Next
isArrayAllocated = IsArray(aArray) And Not IsError(LBound(aArray, 1)) And LBound(aArray, 1) <= UBound(aArray, 1)
Err.Clear: On Error GoTo 0
End Function
'To determine the number of dimensions of an array
'Returns -1 if there is an error
Public Function nbrDimensions(ByVal aArray As Variant) As Long
Dim x As Long, tmpVal As Long
If Not IsArray(aArray) Then
nbrDimensions = -1
Exit Function
End If
On Error GoTo finalDimension
For x = 1 To 65536 'Maximum number of dimensions (size limit) for an array that will work with worksheets under Excel VBA
tmpVal = LBound(aArray, x)
Next x
finalDimension:
nbrDimensions = x - 1
Err.Clear: On Error GoTo 0
End Function
'*****************************************************************************************************************************
'To return an array containing al the coordinates from a specified two-dimension array that have the searched item as value
'Returns an empty array if there is an error or no data
'Returns coordinates in the form of x,y
'*****************************************************************************************************************************
Public Function makeArrayFoundXYIn2DimArray(ByVal itemSearched As Variant, ByVal aArray As Variant) As Variant
Dim tmpArr As Variant, x As Long, y As Long, z As Long
tmpArr = Array()
If IsArray(aArray) Then
If isArrayAllocated(aArray) And nbrDimensions(aArray) = 2 Then
z = 0
For x = LBound(aArray, 1) To UBound(aArray, 1)
For y = LBound(aArray, 2) To UBound(aArray, 2)
If itemSearched = aArray(x, y) Then
If z = 0 Then
ReDim tmpArr(0 To 0)
Else
ReDim Preserve tmpArr(0 To UBound(tmpArr) + 1)
End If
tmpArr(z) = CStr(x) + "," + CStr(y)
z = z + 1
End If
Next y
Next x
End If
End If
makeArrayFoundXYIn2DimArray = tmpArr
Erase tmpArr
End Function
shareeditflag