A
Alan Beban
The following function will return a 3-column array of the index numbers
identifying the locations of the occurrence of a sought value within
a 3-D array. It depends on a number of the other functions in the
freely downloadable file at http://home.pacbell.net/beban. I kept the
lines of code short to try to avoid word wrap in the news readers.
As always, any constructive comments are more than welcome.
Alan Beban
Function ArrayMatch3D(lookupValue3, lookupArray3, _
Optional CaseMatching3 As Boolean = False)
'This procedure outputs a three-column array that
'contains in each row the row index, column index
'and 3rd dimension index of an occurrence of the
'lookup value in the lookup array; the entire
'array is the set of the row, column and 3rd
'dimension indices of all the occurrences of the
'lookup value. *IF THE LOOKUP VALUE DOES NOT OCCUR
'IN THE LOOKUP ARRAY*, then the function will
'return an unannounced error, so the calling code
'should provide for that. E.g., if the calling code
'is in a Sub procedure as x=ArrayMatch3D([whatever]),
'the call could be followed by If IsError(x) Then
'[do whatever should be done if no matches are found].
'The methodology of the function is, conceptualizing
'the input 3-D array as a cube, to extract 2-D planes,
'find matches within each plane with the ArrayMatch
'function (which operates on 2-D arrays), add the
'number of the third dimension to the array of plane
'matches, and add that set of indices to the output array.
Dim arrOut, ArrayOuts, ArraySlices, ArrayOfQs
Dim lb1 As Long, ub1 As Long, lb3 As Long, ub3 As Long
Dim i1 As Long, i2 As Long, i3 As Long, j As Long
Dim xyz As Long, zz As Long, q As Long, Msg
'Insure that lookupArray3 is an array
If Not TypeName(lookupArray3) Like "*()" Then
Msg = "#ERROR! This function accepts only arrays."
MsgBox Msg, 16
Exit Function
End If
'Insure that lookupArray is 3-dimensional
If Not ArrayDimensions(lookupArray3) = 3 Then
Msg = "#ERROR! This function accepts only 3-D arrays."
MsgBox Msg, 16
Exit Function
End If
lb1 = LBound(lookupArray3)
ub1 = UBound(lookupArray3)
lb3 = LBound(lookupArray3, 3)
ub3 = UBound(lookupArray3, 3)
'Redimension array to contain 2-D planes
ReDim ArraySlices(lb3 To ub3)
xyz = 0 'Counter for counting planes
'Load the 2-D planes into a variable
For i1 = lb3 To ub3
ArraySlices(i1) = TwoD(lookupArray3, , xyz)
xyz = xyz + 1
Next i1
q = 0 'Counter for number of occurrences of sought value
'Dimension array to hold number of occurrences in each plane
ReDim ArrayOfQs(lb3 To ub3)
'Determine whether matching is case sensitive and load
'ArrayOfQs
If CaseMatching3 Then
For i2 = lb3 To ub3
q = ArrayCountIf(ArraySlices(i2), lookupValue3, , True)
ArrayOfQs(i2) = q
Next
Else
For i2 = lb3 To ub3
q = ArrayCountIf(ArraySlices(i2), lookupValue3)
ArrayOfQs(i2) = q
Next
End If
'Determine total number of occurrences
'and bail out if none
q = Application.Sum(ArrayOfQs)
If q = 0 Then
ArrayMatch3D = [#VALUE]
Exit Function
End If
'Redimension array to contain output
ReDim arrOut(lb1 To lb1 + q - 1, lb1 To lb1 + 2)
'Redimension array to contain respective outputs
'from each plane
ReDim ArrayOuts(lb3 To ub3)
zz = lb3 'Counter for location in output array
'where each plane output will be added
xyz = 0 'Reset counter for counting planes
'In each plane
For i3 = lb3 To ub3
'If no occurrences, go to next plane
If ArrayOfQs(i3) = 0 Then GoTo skip
'Load the plane output array with the 2-D occurrences
ArrayOuts(i3) = ArrayMatch(lookupValue3, _
TwoD(lookupArray3, , xyz), , , CaseMatching3)
'Increase the upper bound of the plane output array
'to accommodate the index of the 3rd dimension
ResizeArray ArrayOuts(i3), , , , lb1 + 2
'Load the index of the 3rd dimension into the plane
'output array
For j = LBound(ArrayOuts(i3)) To UBound(ArrayOuts(i3))
ArrayOuts(i3)(j, lb1 + 2) = i3
Next j
'Transfer the occurrence locations to the function
'output array
ReplaceSubArray arrOut, ArrayOuts(i3), zz, lb1
'Advance the counter for the addition of
'the next planar results
zz = zz + ArrayOfQs(i3)
'Advance the counter for the extraction of the
'next planar 2-D locations
skip: xyz = xyz + 1
Next i3
ArrayMatch3D = arrOut
End Function
identifying the locations of the occurrence of a sought value within
a 3-D array. It depends on a number of the other functions in the
freely downloadable file at http://home.pacbell.net/beban. I kept the
lines of code short to try to avoid word wrap in the news readers.
As always, any constructive comments are more than welcome.
Alan Beban
Function ArrayMatch3D(lookupValue3, lookupArray3, _
Optional CaseMatching3 As Boolean = False)
'This procedure outputs a three-column array that
'contains in each row the row index, column index
'and 3rd dimension index of an occurrence of the
'lookup value in the lookup array; the entire
'array is the set of the row, column and 3rd
'dimension indices of all the occurrences of the
'lookup value. *IF THE LOOKUP VALUE DOES NOT OCCUR
'IN THE LOOKUP ARRAY*, then the function will
'return an unannounced error, so the calling code
'should provide for that. E.g., if the calling code
'is in a Sub procedure as x=ArrayMatch3D([whatever]),
'the call could be followed by If IsError(x) Then
'[do whatever should be done if no matches are found].
'The methodology of the function is, conceptualizing
'the input 3-D array as a cube, to extract 2-D planes,
'find matches within each plane with the ArrayMatch
'function (which operates on 2-D arrays), add the
'number of the third dimension to the array of plane
'matches, and add that set of indices to the output array.
Dim arrOut, ArrayOuts, ArraySlices, ArrayOfQs
Dim lb1 As Long, ub1 As Long, lb3 As Long, ub3 As Long
Dim i1 As Long, i2 As Long, i3 As Long, j As Long
Dim xyz As Long, zz As Long, q As Long, Msg
'Insure that lookupArray3 is an array
If Not TypeName(lookupArray3) Like "*()" Then
Msg = "#ERROR! This function accepts only arrays."
MsgBox Msg, 16
Exit Function
End If
'Insure that lookupArray is 3-dimensional
If Not ArrayDimensions(lookupArray3) = 3 Then
Msg = "#ERROR! This function accepts only 3-D arrays."
MsgBox Msg, 16
Exit Function
End If
lb1 = LBound(lookupArray3)
ub1 = UBound(lookupArray3)
lb3 = LBound(lookupArray3, 3)
ub3 = UBound(lookupArray3, 3)
'Redimension array to contain 2-D planes
ReDim ArraySlices(lb3 To ub3)
xyz = 0 'Counter for counting planes
'Load the 2-D planes into a variable
For i1 = lb3 To ub3
ArraySlices(i1) = TwoD(lookupArray3, , xyz)
xyz = xyz + 1
Next i1
q = 0 'Counter for number of occurrences of sought value
'Dimension array to hold number of occurrences in each plane
ReDim ArrayOfQs(lb3 To ub3)
'Determine whether matching is case sensitive and load
'ArrayOfQs
If CaseMatching3 Then
For i2 = lb3 To ub3
q = ArrayCountIf(ArraySlices(i2), lookupValue3, , True)
ArrayOfQs(i2) = q
Next
Else
For i2 = lb3 To ub3
q = ArrayCountIf(ArraySlices(i2), lookupValue3)
ArrayOfQs(i2) = q
Next
End If
'Determine total number of occurrences
'and bail out if none
q = Application.Sum(ArrayOfQs)
If q = 0 Then
ArrayMatch3D = [#VALUE]
Exit Function
End If
'Redimension array to contain output
ReDim arrOut(lb1 To lb1 + q - 1, lb1 To lb1 + 2)
'Redimension array to contain respective outputs
'from each plane
ReDim ArrayOuts(lb3 To ub3)
zz = lb3 'Counter for location in output array
'where each plane output will be added
xyz = 0 'Reset counter for counting planes
'In each plane
For i3 = lb3 To ub3
'If no occurrences, go to next plane
If ArrayOfQs(i3) = 0 Then GoTo skip
'Load the plane output array with the 2-D occurrences
ArrayOuts(i3) = ArrayMatch(lookupValue3, _
TwoD(lookupArray3, , xyz), , , CaseMatching3)
'Increase the upper bound of the plane output array
'to accommodate the index of the 3rd dimension
ResizeArray ArrayOuts(i3), , , , lb1 + 2
'Load the index of the 3rd dimension into the plane
'output array
For j = LBound(ArrayOuts(i3)) To UBound(ArrayOuts(i3))
ArrayOuts(i3)(j, lb1 + 2) = i3
Next j
'Transfer the occurrence locations to the function
'output array
ReplaceSubArray arrOut, ArrayOuts(i3), zz, lb1
'Advance the counter for the addition of
'the next planar results
zz = zz + ArrayOfQs(i3)
'Advance the counter for the extraction of the
'next planar 2-D locations
skip: xyz = xyz + 1
Next i3
ArrayMatch3D = arrOut
End Function