I'm looking to access an array using coordinates from a different array, like such. This for a situation where I don't on forehand know the number of dimensions in the data array, so can't really just use an undetermined number of optional variables in a function.
Dim myArray(1 To 4, 1 To 2) As String
Dim myCoord(1 To 2) As Long
myArray(1, 1) = "one_one"
myArray(1, 2) = "one_two"
...
myArray(4, 2) = "four_two"
myCoord(1) = 3
myCoord(2) = 1
MsgBox(myArray(myCoord))
So I'm looking for something like the above messagebox being able to display "three_one". Like in python's my_multidim_list[*[i, j, ..., n]] No idea if it's at all possible in VBA, but well, doesn't seem illogical to me to implement such a possibility.
This was my original answer which provides some background on VBA arrays. I will be expanding it to provide enough background to understand my second answer.
The simple answer is:
Dim myArray(1 To 4, 1 To 2) As String
Dim myCoord(1 To 2) As Long
myArray(1, 1) = "one_one"
myArray(1, 2) = "one_two"
...
myArray(4, 2) = "four_two"
myCoord(1) = 3
myCoord(2) = 1
MsgBox(myArray(myCoord(1), myCoord(2))) ' This is the only change
This is based on each element of myCoord defining the element number of the corresponding dimension of myArray.
Extra information about arrays
When you write Dim myArray(1 To 4, 1 To 2) As String, the number of dimensions and the number of elements in each dimension are fixed until you rewrite this statement with different numbers.
If you write Dim myArray() As String, you are declaring the array but the number of dimensions and their bounds will be defined at run time.
Within your code you can write ReDim myArray(a To b, c To d, e To f) where a to f are integer expressions. In most languages I know, the lower bound is defined by the language as 0 or perhaps 1. With VBA, the lower bound can be anything providing the lower bound is not more than the upper bound. I have only once found a use for a negative lower bound but the option is there.
Later you can write ReDim myArray(g To h) but you will lose all the data within myArray.
Alternatively, you can write ReDim Preserve myArray(a To b, c To d, e To g). Note that a to e are unchanged. With ReDim Preserve only the upper bound of the last dimension can be changed. ReDim Preserve creates a new larger (or smaller) array, copies data from the old array and initialises the new elements to the default value for the data type. Over use of ReDim Preserve can slow your macro down to a crawl because the interpreter runs out of memory but if used carefully it can be very useful.
I would probably define myCoords with the same number of dimensions as myArray but that depends on your objective.
There is a lot more I could say about VBA arrays. If you expand on your objectives I will add appropriate extra information.
My answer has exceeded Stackoverflow's limit of 30,000 characters so I have split it into parts. This is part 2.
This block of code is my test routines. I recommend you try them. If nothing else, they demonstrates how to use the class’s methods.
Option Explicit
Sub Test1()
Dim MyArray1 As New MultDimStrArray
Dim MyArray2 As MultDimStrArray
Dim MyArray3 As MultDimStrArray
Dim Bounds1 As Variant
Dim Bounds2() As String
Set MyArray2 = New MultDimStrArray
Set MyArray3 = New MultDimStrArray
Bounds1 = Array("3 To 10", "2", 5)
ReDim Bounds2(1 To 3)
Bounds2(1) = "3 to 10"
Bounds2(2) = "2"
Bounds2(3) = "5"
' Error-free calls
Call MyArray1.Initialise("3 to 10", "2")
Call MyArray1.OutDiag
Call MyArray2.Initialise(Bounds1)
Call MyArray2.OutDiag
Call MyArray3.Initialise(Bounds2)
Call MyArray3.OutDiag
Call MyArray1.Initialise("3 to 10", 2)
Call MyArray1.OutDiag
Call MyArray1.Initialise(2, "-5 to -2")
Call MyArray1.OutDiag
' Calls that end in an error
Call MyArray1.Initialise("3 to 10", "a")
Call MyArray1.OutDiag
Call MyArray1.Initialise("3 to 2")
Call MyArray1.OutDiag
Call MyArray1.Initialise("2to3")
Call MyArray1.OutDiag
Call MyArray1.Initialise(0)
Call MyArray1.OutDiag
Call MyArray1.Initialise(1.5)
Call MyArray1.OutDiag
Call MyArray1.Initialise("2 to ")
Call MyArray1.OutDiag
Call MyArray1.Initialise(" to 2")
Call MyArray1.OutDiag
End Sub
Sub Test2()
Dim InxD1 As Long
Dim InxD2 As Long
Dim InxD3 As Long
Dim MyArray As New MultDimStrArray
Dim Start As Variant
Dim ValueCrnt As String
Dim Values() As String
Call MyArray.Initialise("3 to 5", 3)
Call MyArray.PutElements(Array(3, 1), _
Array("Three-One", "Three-Two", "Three-Three", _
"Four-One", "Four-Two", "Four-Three", _
"Five-One", "Five-Two", "Five-Three"))
Call MyArray.OutDiag
ReDim Values(0 To 0)
For InxD1 = 3 To 5
For InxD2 = 1 To 3
Start = Array(InxD1, InxD2)
Values(0) = InxD1 & "." & InxD2
Call MyArray.PutElements(Start, Values)
Next
Next
Call MyArray.OutDiag
For InxD1 = 3 To 5
For InxD2 = 1 To 3
Start = Array(InxD1, InxD2)
ValueCrnt = InxD1 & "-" & InxD2
Call MyArray.PutElements(Start, ValueCrnt)
Next
Next
Call MyArray.OutDiag
Call MyArray.Initialise("5 to 10", 3, "-3 to 4")
Debug.Print
ReDim Values(-3 To 4)
For InxD1 = 10 To 5 Step -1
For InxD2 = 1 To 3
Start = Array(InxD1, InxD2, -3)
For InxD3 = -3 To 4
Values(InxD3) = InxD1 & "." & InxD2 & "." & InxD3
Next
Call MyArray.PutElements(Start, Values)
Next
Next
Call MyArray.OutDiag
End Sub
Sub Test3()
Dim InxD1 As Long
Dim InxD2 As Long
Dim InxV As Long
Dim MyArray As New MultDimStrArray
Dim Start As Variant
Dim ValueCrnt As String
Dim Values() As String
Call MyArray.Initialise("3 to 5", 3)
Call MyArray.PutElements(Array(3, 1), _
Array("Three-One", "Three-Two", "Three-Three", _
"Four-One", "Four-Two", "Four-Three", _
"Five-One", "Five-Two", "Five-Three"))
Call MyArray.OutDiag
ReDim Values(1 To 9)
Call MyArray.GetElements(Array(3, 1), Values)
Debug.Print
For InxV = LBound(Values) To UBound(Values)
Debug.Print """" & Values(InxV) & """ ";
Next
Debug.Print
ReDim Values(1 To 3)
Debug.Print
For InxD1 = 3 To 5
Call MyArray.GetElements(Array(InxD1, 1), Values)
For InxV = LBound(Values) To UBound(Values)
Debug.Print """" & Values(InxV) & """ ";
Next
Debug.Print
Next
ReDim Values(1 To 4)
For InxV = LBound(Values) To UBound(Values)
Values(InxV) = "Unchanged"
Next
Call MyArray.GetElements(Array(5, 1), Values)
Debug.Print
For InxV = LBound(Values) To UBound(Values)
Debug.Print """" & Values(InxV) & """ ";
Next
Debug.Print
Debug.Print
For InxD1 = 3 To 5
For InxD2 = 1 To 3
Call MyArray.GetElements(Array(InxD1, InxD2), ValueCrnt)
Debug.Print "(" & InxD1 & ", " & InxD2 & ") contains " & ValueCrnt
Next
Next
End Sub
Over the years, I have created subroutines and functions that perform useful tasks not provided by Excel’s standard subroutines and functions. I use PERSONAL.XLSB as a library to hold all these macros. This is one of those functions which is used by OutDiag.
Option Explicit
Public Function PadR(ByVal Str As String, ByVal PadLen As Long, _
Optional ByVal PadChr As String = " ") As String
' Pad Str with trailing PadChr to give a total length of PadLen
' If the length of Str exceeds PadLen, Str will not be truncated
' Nov15 Coded
' 15Sep16 Added PadChr so could pad with characters other than space
If Len(Str) >= PadLen Then
' Do not truncate over length strings
PadR = Str
Else
PadR = Left$(Str & String(PadLen, PadChr), PadLen)
End If
End Function
My answer has exceeded Stackoverflow's limit of 30,000 characters so I have split it into parts. This is part 1.
Although you did not answer my question about how you intended to fill the array, I decided there was only one viable approach which I have implemented as a class.
If you had asked me a couple of months ago about VBA classes, I would have been dismissive. My view was that if your requirement was complex enough to need a class, VBA was not an appropriate language. I have not totally changed by mind but I recently discovered a VBA StringBuilder class which I found very convenient. Building on that experience, I decided to create a class to address your requirement which showed me how easily a class can hide complex processing from the user.
I have named my class MultDimStrArray. If you do not like this name, change it to something you prefer. If you try my test macros, you will have change the name throughout their module.
My class has no public properties. It has four public methods: Initialise, PutElements, GetElements and OutDiag.
Initalise records the number and bounds of the dimensions. Example calls are:
Dim MyArray1 As New MultDimStrArray
Call MyArray1.Initialise("3 to 10", "2")
and
Dim MyArray2 As MultDimStrArray
Dim Bounds1 As Variant
Bounds1 = Array( ("3 to 10", "2")
Call MyArray1.Initialise(Bounds1)
That is, you can create a multi-dimensional string array using:
Dim MyArray1 As New MultDimStrArray
or
Dim MyArray2 As MultDimStrArray
Set MyArray2 = New MultDimStrArray
The first method is more popular but apparently the second is more efficient.
You can record the bounds of the dimensions in the call of Initialise or in a predefined array. I have used the function Array to load the array. You can load an array in the conventional way if you prefer. All three techniques are demonstrated in macro Test1
Once the MDS array has been initialised, you use PutElements to place values within it. The format of the call is:
Call MyArray.PutElements(Start, Values)
Start is an array with one element per dimension in MyArray; it identifies an element within MyArray. Values can be a single variable or an array of any type providing its elements can be converted to strings. If Values is a single variable or an array of length one, its content will be copied to the element identified by Start. If Values is an array of length greater than one, its contents are copied to MyArray starting at Start. A call of PutElements can place a single value in MyArray or can fill the entire array or anything in between. Macro Test2 shows a variety of ways that PutElements can be used.
GetElements is used to extract a value or values from MyArray. The format of the call is as for PutElement and the parameters are the same; only the direction of the copy is different.
The final method is OutDiag which has no parameters. It output full details of MyArray to the Immediate Window. The Immediate Window can hold up to about 200 rows. I considered output to a text file. If you need this routine and you have large volumes of data, I can amend it for file output.
I have tested the methods but not exhaustively. I believe I have created something that will meet your needs. However, I did not wish to spend more time testing it before confirming it does meet your needs particularly as your real data may different significantly from anything I might create.
Do not look at the class yet other than to look at the how-to-use documentation at the top of each method. Try macros Test1, Test2 and Test3. Adapt them to better match your requirements. Try some real data. I have left my original answer at the end of this answer but you will need more background on VBA arrays to understand the code within the class. I will expand my original answer as my next task.
This block of code is the class. It must be placed in a Class Module named MultDimStrArray. I have left my diagnostic code but have commented most of it out. If you encounter errors, report them to me since I do not think you have the knowledge to debug the class yourself.
Option Explicit
' Members
Private MDSArray() As String ' The MD array is held as a 1D array
' Elements are held in the sequence:
' 1D 2D 3D 4D ... nD
' lb lb lb lb lb to ub
' lb lb lb lb+1 lb to ub
' lb lb lb lb+2 lb to ub
' : : : : :
' lb lb lb ub lb to ub
' lb lb lb+1 lb lb to ub
' : : : : :
' ub ub ub ub lb to ub
' Note: each dimension has its own lower and upper bound
Private DimMax As Long ' Number of dimensions
Private DimOffs() As Long ' Offset from element to equivalent element in next
' repeat for each dimension.
' For dimension 1, this is offset from (a,b,c,d) to (a+1,b,c,d).
' For dimension 2, this is offset from (a,b,c,d) to (a,b+1,c,d).
' And so on.
' Used to convert (a,b,c,d) to index into MDSArray.
Private InxMax As Long ' The total number of elements in the MDS array
Private LBounds() As Long ' Lower bound of each dimension
Private UBounds() As Long ' Upper bound of each dimension
' Methods
Public Sub Class_Initialize()
' Will be called by interpreter when it wishes to initialise an instance of
' MultDimStrArray. Setting NumDim = 0 indicates that the instance has not
' be initialised by the class.
DimMax = 0
End Sub
Public Sub GetElements(ParamArray Params() As Variant)
' Extracts one or more strings starting at a specified element from
' the multi-dimensional string array.
' This sub has two compulsory parameters. The declaration uses a ParamArray
' to allow maximum flexibility in the type of those parameters. Effectively,
' this sub has a declaration of:
' GetElements(ByRef Start() As xxxx, ByRef Values() as yyyy) or
' GetElements(ByRef Start() As xxxx, ByVal Values as yyyy) or
' where xxxx can be any of the integer types plus Variant or String.
' and yyyy can be any type that can be accept a string.
' Start is a one-dimensional array with DimMax, integer elements. If the
' type of the array is Variant or String, the element values must be integer
' or an integer held as a string. The bounds of the array are not important.
' A lower bound of one to match dimension one may be convenient but a lower
' bound of zero or some other value may be used if wished.
' If the MDS array has N dimensions, Start must contain N values each of
' which must be within the bounds for the corresponding dimension. Together,
' the values within Start specify an element with the MDS array.
' Values can be a String or Varient variable or a one-dimensional String or
' Varient array. If the values within the MDS array are known to be
' integer, real or Boolean, then other types. However, if a value within
' the MDS array is not as expected, a call of GetElements may result in a
' fatal, VBA error.
' If Values is a variable or an array with a length of one, the value of
' element Start of the MDS array will be copied to Values.
' If Values is an array with a length greater than one, values will be
' copied to it from the MDS array starting from element Start. If possible,
' array Values will be filled; however, if there are insufficient elements
' in the MDS array, the remaining elements of Values will be left unchanged.
'Debug.Print "GetElements"
If DimMax = 0 Then
Debug.Assert False 'Not initialised
Exit Sub
End If
Dim InxA As Long
Dim InxS As Long
Dim InxV As Long
Dim LB As Long
Dim Start() As Long
Dim UB As Long
LB = LBound(Params)
UB = UBound(Params)
If LB + 1 <> UB Then
Debug.Assert False ' There must be exactly two parameters
Exit Sub
End If
If VarType(Params(LB)) < vbArray Then
Debug.Assert False ' First parameter (Start) must be an array
Exit Sub
End If
' Params(Params(LB)) contains values for Start.
InxS = 1
If UBound(Params(LB)) - LBound(Params(LB)) + 1 <> DimMax Then
Debug.Assert False ' Start must have one entry per dimension
Exit Sub
End If
ReDim Start(1 To DimMax)
For InxV = LBound(Params(LB)) To UBound(Params(LB))
' An error here indicates a value that cannot be converted to a Long
Start(InxS) = Params(LB)(InxV)
If Start(InxS) < LBounds(InxS) Or Start(InxS) > UBounds(InxS) Then
Debug.Assert False ' Index is outside range for dimension
Exit Sub
End If
InxS = InxS + 1
Next
InxA = 1
For InxS = 1 To DimMax
InxA = InxA + (Start(InxS) - LBounds(InxS)) * DimOffs(InxS)
Next
'' Report conversion from coordinates to InxA
'Debug.Print "(";
'For InxS = 1 To DimMax - 1
' Debug.Print Start(InxS) & ", ";
'Next
'Debug.Print Start(DimMax) & ") -> " & InxA
If VarType(Params(UB)) < vbArray Then
' Single value to be extracted from element defined by Start
'Debug.Assert False
' An error here indicates Params(UB) cannot hold the value in the MDS array
Params(UB) = MDSArray(InxA)
Else
' Array of values to be extracted starting at element defined by Start
'Debug.Assert False
'Debug.Print "Params(UB) Bounds: " & LBound(Params(UB)) & " To " & UBound(Params(UB))
For InxV = LBound(Params(UB)) To UBound(Params(UB))
Params(UB)(InxV) = MDSArray(InxA)
'Debug.Print "(" & InxA & ") contains " & Params(UB)(InxV)
InxA = InxA + 1
If InxA > InxMax Then
' Have reached end of MDSArray
Exit For
End If
Next
End If
End Sub
Public Sub Initialise(ParamArray Params() As Variant)
' Initalises an instance of the class by:
' Setting DimMax to number of dimensions
' Recording lower and upper bounds in LBounds and UBounds
' Calculating length of each dimension and recording them in DimOffs
' Calculating total number of entries in array and recording in InxMax
' ReDimming MDSarray to the required length
' The format of the call is: Xxxx.Initialise(parameters)
' Xxxx must be an object of type MultDimStrArray which must have been
' defined in one of these two ways:
' (1) Dim Xxxx As New MultDimStrArray
' (2) Dim Xxxx As MultDimStrArray
' Set Xxxx = New MultDimStrArray
' Most people use method 1 although method 2 results in more efficient code
' according to Charles H Pearson. http://www.cpearson.com/excel/classes.aspx
' In all cases, the parameters are a list of bounds. Those bounds can be
' specified as a list in the Initialise call or can be preloaded into an
' array.
' If the bounds are specified within the call, its format will be something like:
' Call Xxxx.Initialise(BoundsForDim1, BoundsForDim2, BoundsForDim3, ...)
' If the bounds are specified in a preloaded array, its format will be something like:
' Bounds = Array(BoundsForDim1, BoundsForDim2, BoundsForDim3, ...)
' Call Xxxx.Initialise(Bounds)
' or
' Bounds(1) = BoundsForDim1
' Bounds(2) = BoundsForDim2
' Bounds(3) = BoundsForDim3
' : : : :
' Call Xxxx.Initialise(Bounds)
' BoundsForDimN can be
' lb " to " ub
' or
' ub
' Each dimension will have its own lower bound (lb) and upper bound (ub).
' If the lb is not specified, it will default to 1. So 'ub' is equivalent to
' '1 To ub'
'Debug.Print "Initalise"
Dim Bounds() As String
Dim BoundParts() As String
Dim InxB As Long
Dim InxP As Long
Dim LB As Long
Dim NumElmnts As Long
' Convert different formats for Params to a single format
LB = LBound(Params)
If LB = UBound(Params) Then
' Single parameter.
'Debug.Assert False
If VarType(Params(LB)) > vbArray Then
' Params(LB) is an array. Call was of the form: .Initialise(Array)
' Copy contents of Array to Bounds
'Debug.Assert False
DimMax = UBound(Params(LB)) - LBound(Params(LB)) + 1
ReDim Bounds(1 To DimMax)
InxB = 1
For InxP = LBound(Params(LB)) To UBound(Params(LB))
' If get error here, element InxP of Array could not be converted to a string
Bounds(InxB) = Params(LB)(InxP)
InxB = InxB + 1
Next
Else
' Params(LB) is not an array. Call was of the form: .Initialise(X)
' where X is "N to M" or "M". Using this class for a 1D array would
' be inefficient but the code would work so it is not forbidden.
'Debug.Assert False
DimMax = 1
ReDim Bounds(1 To 1)
' If get error here, X could not be converted to a string
Bounds(1) = Params(LB)
End If
Else
' Multiple parameters. Call was of the form: .Initialise(X, Y, Z ...)
' where X, Y, Z and so on can be "N to M" or "M".
' Copy X, Y, Z and so to Bounds
'Debug.Assert False
DimMax = UBound(Params) - LBound(Params) + 1
ReDim Bounds(1 To DimMax)
InxB = 1
For InxP = LBound(Params) To UBound(Params)
' If get error here, one of X, Y, Z and so could not be
' converted to a string
Bounds(InxB) = Params(InxP)
InxB = InxB + 1
Next
End If
'Debug.Print "Bounds in call: ";
'For InxB = 1 To UBound(Bounds)
' Debug.Print Bounds(InxB) & " ";
'Next
'Debug.Print
' Decode values in Bounds and store in in LBounds and UBounds
ReDim LBounds(1 To DimMax)
ReDim UBounds(1 To DimMax)
ReDim DimOffs(1 To DimMax)
InxMax = 1
For InxB = 1 To UBound(Bounds)
' Value can be "lb To Ub" or "Ub"
If IsNumeric(Bounds(InxB)) Then
' Upper bound only
'Debug.Assert False
If Int(Bounds(InxB)) = Val(Bounds(InxB)) Then
' Integer value
'Debug.Assert False
LBounds(InxB) = 1
UBounds(InxB) = Bounds(InxB)
Else
Debug.Print "Invalid parameter: " & Bounds(InxB)
Debug.Assert False ' Real ub; only integer indices allowed
DimMax = 0 ' Not initialised
Exit Sub
End If
Else
' lb To ub
BoundParts = Split(LCase(Bounds(InxB)), " to ")
LB = LBound(BoundParts)
If LB + 1 <> UBound(BoundParts) Then
Debug.Print "Invalid parameter: " & Bounds(InxB)
Debug.Assert False ' Not "ub" and not "lb to ub"
DimMax = 0 ' Not initialised
Exit Sub
Else
If IsNumeric(BoundParts(LB)) And _
IsNumeric(BoundParts(LB + 1)) Then
If Int(BoundParts(LB)) = Val(BoundParts(LB)) And _
Int(BoundParts(LB + 1)) = Val(BoundParts(LB + 1)) Then
'Debug.Assert False
LBounds(InxB) = BoundParts(LB)
UBounds(InxB) = BoundParts(LB + 1)
Else
Debug.Print "Invalid parameter: " & Bounds(InxB)
Debug.Assert False ' lb or ub or both are real; indices must be integer
DimMax = 0 ' Not initialised
Exit Sub
End If
Else
Debug.Print "Invalid parameter: " & Bounds(InxB)
Debug.Assert False ' One or both of lb and ub are non-numeric or missing
DimMax = 0 ' Not initialised
Exit Sub
End If
End If
End If
If LBounds(InxB) > UBounds(InxB) Then
Debug.Print "Invalid parameter: " & Bounds(InxB)
Debug.Assert False ' lb must be less than ub
DimMax = 0 ' Not initialised
Exit Sub
End If
Next InxB
' Calculate offset to equivalent element in next repeat for each dimension.
DimOffs(DimMax) = 1
NumElmnts = (UBounds(DimMax) - LBounds(DimMax) + 1)
For InxB = DimMax - 1 To 1 Step -1
DimOffs(InxB) = NumElmnts * DimOffs(InxB + 1)
NumElmnts = (UBounds(InxB) - LBounds(InxB) + 1) ' Need for next loop
Next
InxMax = NumElmnts * DimOffs(1)
ReDim MDSArray(1 To InxMax)
End Sub
Public Sub OutDiag()
Dim ColWidthCrnt As Long
Dim ColWidthTotalLastDim As Long
Dim ColWidthsLast() As Long
Dim ColWidthsNotLast() As Long
Dim Coords() As Long
Dim InxA As Long ' Index into MDSArray
Dim InxC As Long ' Index into Coords
Dim InxD As Long ' Index into dimensions
'Dim InxL As Long ' Index into Last dimension
Dim InxWL As Long ' Index into ColWidthsLast
'Debug.Print "OutDiag"
If DimMax = 0 Then
Debug.Assert False 'Not initialised
Exit Sub
End If
Debug.Print "DimMax=" & DimMax
For InxD = 1 To DimMax
Debug.Print "Dim" & InxD & " Bounds=" & LBounds(InxD) & " to " & _
UBounds(InxD) & " Offset to next repeat=" & DimOffs(InxD)
Next
Debug.Print "InxMax=" & InxMax
Debug.Print
ReDim ColWidthsNotLast(1 To DimMax - 1)
ReDim ColWidthsLast(LBounds(DimMax) To UBounds(DimMax))
' Ensure columns for all but last wide enough for headings and coordinates
For InxD = 1 To DimMax - 1
ColWidthsNotLast(InxD) = Len("D" & CStr(InxD))
'Debug.Print "ColWidthsNotLast(" & InxD & ") initialsed to " & _
' ColWidthsNotLast(InxD) & " because of header ""D" & _
' CStr(InxD) & """"
ColWidthCrnt = Len(CStr(LBounds(InxD)))
If ColWidthsNotLast(InxD) < ColWidthCrnt Then
Debug.Assert False
ColWidthsNotLast(InxD) = ColWidthCrnt
'Debug.Print "ColWidthsNotLast(" & InxD & ") increased to " & _
' ColWidthsNotLast(InxD) & " because of lower bound """ & _
' CStr(LBounds(InxD)) & """"
End If
ColWidthCrnt = Len(CStr(UBounds(InxD)))
If ColWidthsNotLast(InxD) < ColWidthCrnt Then
Debug.Assert False
ColWidthsNotLast(InxD) = ColWidthCrnt
'Debug.Print "ColWidthsNotLast(" & InxD & ") increased to " & _
' ColWidthsNotLast(InxD) & " because of upper bound """ & _
' CStr(UBounds(InxD)) & """"
End If
Next
' Ensure columns for last dimension wide enough for headings
For InxWL = LBounds(DimMax) To UBounds(DimMax)
ColWidthsLast(InxWL) = Len(CStr(InxD))
'Debug.Print "ColWidthsLast(" & InxWL & ") initialised to " & _
' ColWidthsLast(InxWL) & " because of index """ & CStr(InxWL) & """"
Next
' Ensure columns for last dimension wide enough for values
ReDim Coords(1 To DimMax)
' Initialise Coords to indices for first entry in MDS array
For InxC = 1 To DimMax
Coords(InxC) = LBounds(InxC)
Next
'' Output co-ordinates to show which elements caused increase in width
'Debug.Print "(";
'For InxD = 1 To DimMax - 1
' Debug.Print Coords(InxD) & ", ";
'Next
'Debug.Print Coords(DimMax) & ") ";
InxA = 1
' Check length of each value against length of each column for last dimension
' Increase length of column for last dimension if necessary
Do While True
' Length for entry corrsponding specified by Coords
ColWidthCrnt = Len(MDSArray(InxA))
' Column for current index into last dimension
InxWL = Coords(DimMax)
' Increase column width if necessary
If ColWidthsLast(InxWL) < ColWidthCrnt Then
'Debug.Assert False
ColWidthsLast(InxWL) = ColWidthCrnt
'' Report reason for increased column width
'Debug.Print "ColWidthsLast(" & InxWL & ") increased to " & _
' ColWidthsLast(InxWL) & " because of value """ & _
' MDSArray(InxA) & """"
End If
' Step Coords to next entry
For InxD = DimMax To 1 Step -1
If Coords(InxD) < UBounds(InxD) Then
Coords(InxD) = Coords(InxD) + 1
Exit For
Else
Coords(InxD) = LBounds(InxD)
End If
Next
InxA = InxA + 1 ' Step index into MDSArray to match Coords
If InxA > InxMax Then
Exit Do
End If
'' Output co-ordinates to show which elements caused increase in width
'Debug.Print "(";
'For InxD = 1 To DimMax - 1
' Debug.Print Coords(InxD) & ", ";
'Next
'Debug.Print Coords(DimMax) & ") ";
Loop
'Debug.Print
' Output header
Debug.Print "Value for each element in MDSArray"
Debug.Print "|";
For InxD = 1 To DimMax - 1
Debug.Print PadR("D" & CStr(InxD), ColWidthsNotLast(InxD)) & "|";
Next
Debug.Print "|";
For InxWL = LBounds(DimMax) To UBounds(DimMax)
Debug.Print PadR(CStr(InxWL), ColWidthsLast(InxWL)) & "|";
Next
Debug.Print
' Output data rows.
' One row for each value of each index for every dimension except last
' Left of row contains indices for dimensions other thsn last
' Right of row contains values for each index into last dimension
' Initialise Coords to indices for first entry in MDS array
For InxC = 1 To DimMax
Coords(InxC) = LBounds(InxC)
Next
InxA = 1
Do While InxA <= InxMax
Debug.Print "|";
' Output current index for dimensions except last
For InxD = 1 To DimMax - 1
Debug.Print PadR(Coords(InxD), ColWidthsNotLast(InxD)) & "|";
Next
Debug.Print "|";
' Output values for each index into last dimension
Do While True
Debug.Print PadR(MDSArray(InxA), ColWidthsLast(Coords(DimMax))) & "|";
' Step Coords to next entry
For InxD = DimMax To 1 Step -1
If Coords(InxD) < UBounds(InxD) Then
Coords(InxD) = Coords(InxD) + 1
Exit For
Else
Coords(InxD) = LBounds(InxD)
End If
Next
InxA = InxA + 1 ' Step index into MDSArray to match Coords
If InxA > InxMax Then
Exit Do
End If
If Coords(DimMax) = LBounds(DimMax) Then
' Start of new row
Debug.Print
Exit Do
End If
Loop
Loop
Debug.Print
End Sub
Public Sub PutElements(ParamArray Params() As Variant)
' Saves one or more strings starting at a specified element within
' the multi-dimensional string array.
' This sub has two compulsory parameters. The declaration uses a ParamArray
' to allow maximum flexibility in the type of those parameters. Effectively,
' this sub has a declaration of:
' PutElements(ByRef Start() As xxxx, ByRef Values() as yyyy) or
' PutElements(ByRef Start() As xxxx, ByVal Values as yyyy) or
' where xxxx can be any of the integer types plus Variant or String.
' and yyyy can be any type that can be converted to a string plus
' Variant providing all the values within the Variant can be
' converted to strings.
' Start is a one-dimensional array with DimMax, integer elements. If the
' type of the array is Variant or String, the element values must be integer
' or an integer held as a string. The bounds of the array are not important.
' A lower bound of one to match dimension one may be convenient but a lower
' bound of zero or some other value may be used if wished.
' If the MDS array has N dimensions, Start must contain N values each of
' which must be within the bounds for the corresponding dimension. Together,
' the values within Start specify an element with the MDS array.
' Values can be a variable of any type that can be converted to a string.
' Alternately, Values can be a one-dimensional array containing one or more
' elements. If Values contains one element, the value of that element will be
' saved to element Start of the MDS array. If Values contains more than one
' element, the values of those elements will be saved to the MDS array
' starting at Start and continuing in the sequence defined at the top of this
' module until all values in Values have been saved or the last element of
' MDSArray has been reached.
'Debug.Print "PutElements"
If DimMax = 0 Then
Debug.Assert False 'Not initialised
Exit Sub
End If
Dim InxA As Long
Dim InxS As Long
Dim InxV As Long
Dim LB As Long
Dim Start() As Long
Dim UB As Long
LB = LBound(Params)
UB = UBound(Params)
If LB + 1 <> UB Then
Debug.Assert False ' There must be exactly two parameters
Exit Sub
End If
If VarType(Params(LB)) < vbArray Then
Debug.Assert False ' First parameter (Start) must be an array
Exit Sub
End If
' Params(Params(LB)) contains values for Start.
InxS = 1
If UBound(Params(LB)) - LBound(Params(LB)) + 1 <> DimMax Then
Debug.Assert False ' Start must have one entry per dimension
Exit Sub
End If
ReDim Start(1 To DimMax)
For InxV = LBound(Params(LB)) To UBound(Params(LB))
' An error here indicates a value that cannot be converted to a Long
Start(InxS) = Params(LB)(InxV)
If Start(InxS) < LBounds(InxS) Or Start(InxS) > UBounds(InxS) Then
Debug.Assert False ' Index is outside range for dimension
Exit Sub
End If
InxS = InxS + 1
Next
InxA = 1
For InxS = 1 To DimMax
InxA = InxA + (Start(InxS) - LBounds(InxS)) * DimOffs(InxS)
Next
'' Report conversion from coordinates to InxA
'Debug.Print "(";
'For InxS = 1 To DimMax - 1
' Debug.Print Start(InxS) & ", ";
'Next
'Debug.Print Start(DimMax) & ") -> " & InxA
If VarType(Params(UB)) < vbArray Then
' Single value to be stored in element defined by Start
'Debug.Assert False
' An error here indicates Params(UB) cannot be converted to a string
MDSArray(InxA) = Params(UB)
Else
' Array of values to be stored starting at element defined by Start
'Debug.Assert False
'Debug.Print "Params(UB) Bounds: " & LBound(Params(UB)) & " To " & UBound(Params(UB))
For InxV = LBound(Params(UB)) To UBound(Params(UB))
MDSArray(InxA) = Params(UB)(InxV)
'Debug.Print Params(UB)(InxV) & " -> (" & InxA & ")"
InxA = InxA + 1
If InxA > InxMax Then
' Have reached end of MDSArray
Exit For
End If
Next
End If
End Sub
VBA arrays, Variants and Variant arrays
This answer provides the background necessary to understand some of the code within the other answers and to understand why I rejected an alternative approach.
To declare simple variables, I write:
Dim A As Long
Dim B As String
Dim C As Boolean
Dim D As Integer
Dim E As Double
VBA has a selection of intrinsic data types that are not very different from those available with other languages.
VBA has another type:
Dim F As Variant
A Variant might be thought of as untyped or as a container. If I write:
A = 5 ' OK because A is Long
A = "abc" ' Will fail a n alphabetic string cannot be saved in a Long
A = "123" ' OK because string "123" is automatically converted to integer 123
On the other hand, I can write the following without any failures:
F = 5
F = "abc"
F = True
F = 1.23
Each of these values will be held correctly. F can be used in any expression for which its current value is appropriate:
F = 5
F = F + 2
F = "abc"
F = F & "def"
The above statements are all valid but
F = "abc"
F = F + 2
will fail because after setting F to "abc", it cannot be used in an arithmetic expression.
A Variant can also hold an Excel worksheet, a Word document or any Office object. A Variant can also hold an array. When a Variant holds an object or an array, the syntax is as though the Variant has become that object or array. So:
F = Worksheets("Data”)
F.Range("A1") = "abc"
Above, F is now effectively a variable of type Worksheet and any of a Worksheet’s properties or methods can be accessed by F. This was just to give a brief taste on the full scope of Variants; the remainder of this tutorial is limited to arrays.
I can “convert” a Variant to an array in one of two ways:
1) F = VBA.Array(1, "abc", True)
2) ReDim F(0 To 2)
VBA.Array is a function which returns a one-dimensional Variant array with lower bound 0 and enough elements to hold the supplied values. I can also write F = Array(1, "abc", True). Function Array is the same as Function VBA.Array except the lower bound depends on the present and value of the Option Base command.
I only use function Array if I am going to use function LBound to determine the lower bound. I do not fully understand what is and what is not effected by the Option Base command since it is not fully documented. I have seen differences between different versions of different Microsoft products which I am sure are accidental. I am confident a new Microsoft programmer has assumed an old product operates in a sensible manner when it does not. I am very careful to specify both lower and upper bounds if I can. If I cannot specify the lower bound, I check it. I still use routines I wrote under Excel 2003. I believe the lack of problems I encounter with old routines is because I avoid making assumptions about how Excel operates if it is not fully documented.
Returning to the tutorial, ReDim F(0 To 2) effectively converts F to an array with three elements..
All previous discussions have been about one-dimensional arrays. Conventional multi-dimensional arrays are also possible:
Dim G(1 to 5) As Long
Dim H(1 to 5, 1 To 4) As String
Dim I(1 to 5, 1 To 4, 0 To 3) As Boolean
or
Dim G() As Long
Dim H() As String
Dim I() As Boolean
ReDim G(1 to 5)
ReDim H(1 to 5, 1 To 4)
ReDim I(1 to 5, 1 To 4, 0 To 3)
With the first block, the number and size of the dimensions are fixed at compile time. With second block, the number and size of the dimensions are set at runtime and can be changed.
In either case, the syntax for access is:
G(n) = 3
H(n, m) = "abc"
I(n, m, o) = True
This type of multi-dimensional is inappropriate for your requirement. Although the bounds can be changed at runtime, the number of dimensions cannot be changed within a ReDim statement, A Select statement would be need to select from a long list of pre-prepared ReDim statements with one for each possible number of dimensions.
The alternative is ragged or jagged arrays although without them being ragged.
Consider:
Dim F As Variant
ReDim F(0 To 2)
F(0) = VBA.Array(1, 2, 3)
F(1) = VBA.Array(4, 5, 6)
F(2) = VBA.Array(7, 8, 9)
I have made F into a three element array and have then made each element of F into an array. To access the elements of the inner arrays, I write: F(n)(m) where both n and m can be 0, 1 or 2.
I can continue:
F(0)(0) = VBA.Array(10, 11, 12)
After this change, element F(0)(0)(0) has a value of 10 and F(0)(0)(1) has a value of 11.
I can continue this indefinitely. I have read that VBA has a limit of 60 dimensions with conventional multi-dimensional arrays. I have not tried but I cannot see why there would be any limit on the number of dimensions with this technique other than memory.
This technique appears to have the same limitation as regular multi-dimensional arrays. I can write F(0)(0) or F(0)(0)(0) but I cannot change the depth of the simple variable at runtime.
There is also the problem that ReDim F(0)(0 To 2) is rejected by the compiler as invalid syntax. That was why I used VBA.Array to convert F(0) to an array.
The solution is recursion. Consider:
Call ReDimVar(F, "1 To 2", "3 To 4", "0 To 5")
ReDimVar can:
ReDim F(1 To 2)
Call ReDimVar(F(1), "3 To 4", "0 To 5")
Call ReDimVar(F(2), "3 To 4", "0 To 5")
All this can be handled with simple loops. I rejected this technique because recursion is slow and your question implies significant volumes of data and many dimensions. However, to demonstrate that it would work, play with the following:
Sub TryMDVA()
' Demonstrate how to:
' 1) Convert a Variant into a multi-dimension array
' 2) Store values in every element of that multi-dimension array
' 3) Extract values from every element of that multi-dimension array
Dim Coords() As Long
Dim ElementValue As String
Dim InxB As Long ' Index for both Bounds and Coords
Dim InxD1 As Long
Dim InxD2 As Long
Dim InxD3 As Long
Dim LwrBnds As Variant
Dim MDVA As Variant
Dim UppBnds As Variant
LwrBnds = Array(1, 0, -3)
UppBnds = Array(2, 5, 4)
ReDim Bounds(LBound(LwrBnds) To UBound(LwrBnds))
ReDim Coords(LBound(LwrBnds) To UBound(LwrBnds))
Call FormatMDVA(MDVA, LwrBnds, UppBnds)
Debug.Print "Results of formatting MDVA"
Debug.Print "Bounds of MDVA are " & LBound(MDVA) & " to " & UBound(MDVA)
Debug.Print "Bounds of MDVA(1) are " & LBound(MDVA(1)) & " to " & UBound(MDVA(1))
Debug.Print "Bounds of MDVA(2) are " & LBound(MDVA(2)) & " to " & UBound(MDVA(2))
Debug.Print "Bounds or MDVA(1)(0) are " & LBound(MDVA(1)(0)) & " to " & UBound(MDVA(1)(0))
Debug.Print "Bounds or MDVA(2)(5) are " & LBound(MDVA(2)(5)) & " to " & UBound(MDVA(2)(5))
' Initialise Coords to lower bound of each dimension
For InxB = LBound(LwrBnds) To UBound(LwrBnds)
Coords(InxB) = LwrBnds(InxB)
Next
Do While True
' Build element value from coordinates
ElementValue = Coords(LBound(Coords))
For InxB = LBound(LwrBnds) + 1 To UBound(LwrBnds)
ElementValue = ElementValue & "." & Coords(InxB)
Next
' Store element value in element of MDVA specified by Coords
Call PutElement(MDVA, Coords, ElementValue)
' Step Coords. Think of Coords as a speedometer with each wheel marked
' with the available index values for a dimension. Starting on the right,
' check each wheel against the relevant ubound. If it is less than the
' ubound, step it by 1. If it is the upper bound, reset it to the lower
' bound and try the next wheel to the left. If the leftmost wheel is
' to be reset, Coords has been set to all possible values.
For InxB = UBound(LwrBnds) To LBound(LwrBnds) Step -1
If Coords(InxB) < UppBnds(InxB) Then
Coords(InxB) = Coords(InxB) + 1
Exit For
Else
If InxB = LBound(LwrBnds) Then
Exit Do
End If
Coords(InxB) = LwrBnds(InxB)
End If
Next
Loop
Debug.Print "Example values from within MDVA"
Debug.Print "MDVA(1)(0)(-3) = " & MDVA(1)(0)(-3)
Debug.Print "MDVA(1)(0)(-2) = " & MDVA(1)(0)(-2)
Debug.Print "MDVA(2)(3)(0) = " & MDVA(2)(3)(0)
Debug.Print "MDVA(2)(5)(4) = " & MDVA(2)(5)(4)
' Initialise Coords to upper bound of each dimension
For InxB = LBound(UppBnds) To UBound(UppBnds)
Coords(InxB) = UppBnds(InxB)
Next
Debug.Print "List of all values in MDVA"
Do While True
' Output value of element of MDVA identified by Coords
Debug.Print "MDVA(" & Coords(LBound(UppBnds));
For InxB = LBound(UppBnds) + 1 To UBound(UppBnds)
Debug.Print ", " & Coords(InxB);
Next
Debug.Print ") = """ & GetElement(MDVA, Coords) & """"
' Set next value of Coords. Similar to code block in PutElement
' but in the opposite direction
For InxB = UBound(LwrBnds) To LBound(LwrBnds) Step -1
If Coords(InxB) > LwrBnds(InxB) Then
Coords(InxB) = Coords(InxB) - 1
Exit For
Else
If InxB = LBound(LwrBnds) Then
Exit Do
End If
Coords(InxB) = UppBnds(InxB)
End If
Next
Loop
End Sub
Sub FormatMDVA(ByRef MDVA As Variant, LwrBnds As Variant, UppBnds As Variant)
' Size MDVA according to the bounds in the first elements of LwrBnds and
' UppBnds. If there are further elements in LwrBnds and UppBnds, call
' FormatMDVA to format every element of MDVA according to the remaining
' elements.
Dim InxB As Long
Dim InxM As Long
Dim LB As Long
Dim SubLwrBnds As Variant
Dim SubUppBnds As Variant
LB = LBound(LwrBnds)
ReDim MDVA(LwrBnds(LB) To UppBnds(LB))
If LBound(LwrBnds) = UBound(LwrBnds) Then
' All bounds applied
Else
' Another dimension to format
ReDim SubLwrBnds(LB + 1 To UBound(LwrBnds))
ReDim SubUppBnds(LB + 1 To UBound(UppBnds))
' Copy remaining bounds to new arrays
For InxB = LB + 1 To UBound(LwrBnds)
SubLwrBnds(InxB) = LwrBnds(InxB)
SubUppBnds(InxB) = UppBnds(InxB)
Next
For InxM = LwrBnds(LB) To UppBnds(LB)
Call FormatMDVA(MDVA(InxM), SubLwrBnds, SubUppBnds)
Next
End If
End Sub
Function GetElement(ByRef MDVA As Variant, ByRef Coords() As Long) As Variant
' Return the value of the element of MDVA identified by Coords
Dim InxC As Long
Dim LB As Long
Dim SubCoords() As Long
LB = LBound(Coords)
If LB = UBound(Coords) Then
' Have reached innermost array
GetElement = MDVA(Coords(LB))
Else
' At least one more nested array
ReDim SubCoords(LB + 1 To UBound(Coords))
For InxC = LB + 1 To UBound(Coords)
SubCoords(InxC) = Coords(InxC)
Next
GetElement = GetElement(MDVA(Coords(LB)), SubCoords)
End If
End Function
Sub PutElement(ByRef MDVA As Variant, ByRef Coords() As Long, _
ElementValue As Variant)
' Save the value of ElementValue in the element of MDVA identified by Coords
Dim InxC As Long
Dim LB As Long
Dim SubCoords() As Long
LB = LBound(Coords)
If LB = UBound(Coords) Then
' Have reached innermost array
MDVA(Coords(LB)) = ElementValue
Else
' At least one more nested array
ReDim SubCoords(LB + 1 To UBound(Coords))
For InxC = LB + 1 To UBound(Coords)
SubCoords(InxC) = Coords(InxC)
Next
Call PutElement(MDVA(Coords(LB)), SubCoords, ElementValue)
End If
End Sub
Related
I need to combine unique values from ranges (with condition) into another ranges on the same rows.
Actually, I post a similar question two days ago Link and the provided answer works as I formulated that mentioned question.
But later, I faced a new issues and I preferred to ask a new one to make it more clear :
(1) if all cells on a separate range e.g [C7:C8] have empty value,
then I got on that line mtch = Application.Match(arr(i, 3), arrDC, 0)
Run-time error '13':Type mismatch
I can use On Error Resume Next before that line ,but I think it’s not the proper way to handle that error.
(2) if some cells or all on a separate range e.g [B9:B10] have empty value,
then I got blank lines (on top the combined values) at the final result.
This is a link for the provided example with the expected output.
In advance, great thanks for your learning support and help.
Sub CombineRangesOneColumn_v2()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'_________________________________________
Dim sh As Worksheet, lastR As Long, arr, arrDict, dict As Object
Dim arrDB, arrDC, mtch, arrFin, i As Long, j As Long, k As Long
Set sh = ActiveSheet
lastR = sh.Range("A" & sh.Rows.Count).End(xlUp).Row
arr = sh.Range("A2:C" & lastR).Value2
Set dict = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(arr)
If Not dict.Exists(arr(i, 1)) Then
dict.Add arr(i, 1), Array(arr(i, 2), arr(i, 3)) 'Place the strings from columns "B" and "C"
Else
arrDict = dict(arr(i, 1)) 'extract the array from dict items (it cnnot be modified inside the item)
arrDict(0) = arrDict(0) & "|" & arr(i, 2) 'place in the array first element the strings collected from B:B
arrDC = Split(arrDict(1), vbLf) 'try splitting the second array element (string(s) from C:C)
If UBound(arrDC) = 0 Then 'if only one element:
If arrDC(0) <> arr(i, 3) Then
arrDict(1) = arrDict(1) & IIf(arr(i, 3) = "", "", vbLf & arr(i, 3)) 'add to it the value from C:C, separated by vbLf
End If
Else
mtch = Application.Match(arr(i, 3), arrDC, 0) 'check unicity of the string from C:C
If IsError(mtch) Then 'only if not existing:
arrDict(1) = arrDict(1) & IIf(arr(i, 3) = "", "", vbLf & arr(i, 3)) 'add it to the string to be used in the next step
End If
End If
dict(arr(i, 1)) = arrDict 'put back the array in the dictionary item
End If
Next i
ReDim arrFin(1 To UBound(arr), 1 To 1): k = 1 'redim the final array and initialize k (used to fill the array)
For i = 0 To dict.Count - 1 'iterate between the dictionary keys/items:
arrDict = dict.Items()(i) 'place the item array in an array
arrDB = Split(arrDict(0), "|") 'obtain an array of B:B strins from the item first array element
For j = 0 To UBound(arrDB) 'how many unique keys exists 'place the dictionry key per each iteration
arrFin(k, 1) = arrDB(j) & vbLf & arrDict(1) 'build the string of the second column
k = k + 1
Next j
Next i
'Drop the processed result near the existing range (for easy visual comparison):
sh.Range("D2").Resize(UBound(arrFin), 1).Value2 = arrFin
'_______________________________________________
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Combine Unique Values
Sub Extract_unique_values_and_combine_in_adjacent_cells()
' The delimiter between the 2nd column value and the 3rd column values.
Const dDelimiter As String = vbLf ' use e.g. 'vbLf & vbLf' to understand
' The delimiter between the 3rd column values.
Const vDelimiter As String = vbLf ' use e.g. ',' to understand
' Reference the worksheet ('ws').
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
' Reference the table range (has headers).
Dim strg As Range: Set strg = ws.Range("A1").CurrentRegion
' Calculate the number of data rows ('rCount')(exclude header row).
Dim rCount As Long: rCount = strg.Rows.Count - 1
' Reference the source data range ('srg') (no headers).
Dim srg As Range: Set srg = strg.Resize(rCount).Offset(1)
' Write the values from the source range to a 2D one-based array,
' the source array ('sData').
Dim sData() As Variant: sData = srg.Value
' Reference a newly created dictionary object ('dict').
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare ' case-insensitive i.e. 'a = A'
' The dictionary's 'keys' will hold the unique values from the 1st column,
' while each associated dictionary's 'item' will hold another dictionary
' whose 'keys' will hold the unique values from the 3rd column.
Dim Key1 As Variant
Dim Key3 As Variant
Dim r As Long
' Loop through the rows of the source array...
For r = 1 To rCount
' Write the current value from the 1st column to a variable ('Key1')...
Key1 = sData(r, 1)
' ... and check if it isn't already a 'key' of the dictionary.
If Not dict.Exists(Key1) Then ' not a 'key' in dictionary
' Add the value as the 'key' and assign a newly created dictionary
' to the associated item ('dict(Key1)').
Set dict(Key1) = CreateObject("Scripting.Dictionary")
dict(Key1).CompareMode = vbTextCompare ' case-insensitive
'Else ' is a 'key' of the dictionary; do nothing
End If
' Write the current value from the 3rd column to a variable ('Key3')...
Key3 = sData(r, 3)
If Not IsError(Key3) Then ' exclude errors
If Len(CStr(Key3)) > 0 Then ' exclude blanks
' ... and add it to the 'keys' of the current 'item dictionary'.
dict(Key1)(Key3) = Empty
End If
End If
Next r
' Write the length of the 3rd column delimiter to a variable ('vLen')
' (to not calculate it over and over since it will be used in a loop).
Dim vLen As Long: vLen = Len(vDelimiter)
' Concatenate the dictionary item dictionaries' keys to strings
' and replace the item dictionaries with those strings.
Dim String3 As String
' Loop through the keys of the dictionary (dict.Keys)...
For Each Key1 In dict.Keys
' Loop through the keys of the item dictionary ('dict(Key1).Keys')...
For Each Key3 In dict(Key1).Keys
' ... and concatenate the values into a string ('String3').
String3 = String3 & Key3 & vDelimiter
Next Key3
If Len(String3) > 0 Then ' the item dictionary was not empty
' Remove the redundant right most delimiter.
String3 = Left(String3, Len(String3) - vLen)
'Else ' the item dictionary was empty; do nothing
End If
' Replace the item dictionary with the string.
dict(Key1) = String3
' Reset the string variable.
String3 = vbNullString
Next Key1
' Define the the destination array ('dData'),
' a 2D one-based one-column string array with the same number of rows
' as the number of rows of the source array, .
Dim dData() As String: ReDim dData(1 To rCount, 1 To 1)
Dim String2 As String
' Loop through the rows of the source array...
For r = 1 To rCount
' Write the 2nd column value, converted to a string, to a variable.
String2 = CStr(sData(r, 2))
' Write the dictionary item associated to the key
' for the 1st column value to a variable.
String3 = dict(sData(r, 1))
If Len(String2) = 0 Then ' the 2nd column value is blank
If Len(String3) > 0 Then ' the current string is not an empty string
' Write just the 3rd column (concatenated) strings.
dData(r, 1) = String3
'Else ' the current string is an empty string; do nothing
' Note that each element of the destination array is initially
' an empty string since it was declared 'As String'.
End If
Else ' the 2nd column value is not blank
If Len(String3) > 0 Then ' the current string is not an empty string
' Concatenate the 2nd and 3rd column strings.
dData(r, 1) = String2 & dDelimiter & String3
Else ' the current string is an empty string
' Write just the 2nd column string.
dData(r, 1) = String2
End If
End If
Next r
' Write the values from the destination array to the 2nd column
' of the source data range (no headers).
srg.Columns(2).Value = dData
' Clear the 3rd column of the source table range (has headers).
strg.Columns(3).Clear
End Sub
Please, try the next version. It should do what (I understood) you need:
Sub CombineRangesOneColumnEmptyRemoved()
Dim sh As Worksheet, lastR As Long, arr, arrDict, dict As Object
Dim arrDB, arrDC, mtch, arrFin, i As Long, j As Long, k As Long
Set sh = ActiveSheet
lastR = sh.Range("A" & sh.rows.count).End(xlUp).row
arr = sh.Range("A2:C" & lastR).Value2
Set dict = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(arr)
If Not dict.Exists(arr(i, 1)) Then
dict.Add arr(i, 1), Array(arr(i, 2), arr(i, 3)) 'place the strings from columns B and C
Else
arrDict = dict(arr(i, 1)) 'extract the array from dict items (it cnnot be modified inside the item)
arrDict(0) = arrDict(0) & "|" & arr(i, 2) 'place in the array first element the strings collected from B:B
arrDC = Split(arrDict(1), vbLf) 'try splitting the second array element (string(s) from C:C)
If UBound(arrDC) = 0 Then 'if only one element(for second occurrence):
If arrDict(1) <> arr(i, 3) And arr(i, 3) <> "" Then 'not add it to the string if empty or already existing
arrDict(1) = arrDict(1) & vbLf & arr(i, 3)
End If
dict(arr(i, 1)) = arrDict
ElseIf UBound(arrDC) = -1 Then 'nothing (arrDict(1) is empty)
dict(arr(i, 1)) = Array(arrDict(0), arr(i, 3)) 'place the string of the third column (even empty...)
Else
mtch = Application.match(arr(i, 3), arrDC, 0) 'check unicity of the string from C:C
If IsError(mtch) Then 'only if not existing:
arrDict(1) = arrDict(1) & IIf(arr(i, 3) = "", "", vbLf & arr(i, 3)) 'add it to the string to be used in the next step
End If
dict(arr(i, 1)) = arrDict 'put back the changed array in the dictionary item
End If
End If
Next i
ReDim arrFin(1 To UBound(arr), 1 To 1): k = 1 'redim the final array and initialize k (used to fill the array)
For i = 0 To dict.count - 1 'iterate between the dictionary keys/items:
arrDict = dict.Items()(i) 'place the item array in an array
arrDB = Split(arrDict(0), "|") 'obtain an array of B:B strins from the item first array element
For j = 0 To UBound(arrDB) 'how many unique keys exists!
arrFin(k, 1) = arrDB(j) & IIf(arrDict(1) = "", "", vbLf & arrDict(1)) 'build the string of the second column
k = k + 1
Next j
Next i
'drop the processed result near the existing range:
sh.Range("D2").Resize(UBound(arrFin), 1).Value2 = arrFin
End Sub
If after testing it, nothing inconvenient appears, you may ReDim arrFin to have two columns, the code will load it without any code modification, but its content will be dropped in "B2" resized for two columns (Resize(UBound(arrFin), 2)). In this way, D:D will be errased in the same step.
Just for alternatives sake:
Formula in E2:
=TEXTJOIN(CHAR(10),,B2,UNIQUE(FILTER(C$2:C$10,A$2:A$10=A2)))
Or, if available, spill all results in a single go:
=BYROW(A2:B10,LAMBDA(x,TEXTJOIN(CHAR(10),,INDEX(x,2),UNIQUE(FILTER(C$2:C$10,A$2:A$10=INDEX(x,1))))))
I'm looking to speed up a For Loop (as per code below) by incorporating the use of an Array.
Would really appreciate some advice on how to do this:
Sub DetectedCheck()
'counts rows in sheet 1 and 2.
With Sheets(1)
reconrows = .Range("a" & .Rows.Count).End(xlUp).Row
End With
'Checks that the new data has both an assigned and detected role and adds "No Issue" to column Q if valid.
For i = 2 To reconrows
If ActiveWorkbook.Sheets(1).Range("J" & i).Value <> "Not Found" And ActiveWorkbook.Sheets(1).Range("K" & i).Value <> "" Then
ActiveWorkbook.Sheets(1).Range("S" & i).Value = "No Issue"
End If
Next i
End Sub
Please, try the next way:
Sub DetectedCheck()
Dim sh As Worksheet, reconRows As Long, arrJK, arrS, i As Long
Set sh = Sheets(1)
reconRows = sh.Range("a" & sh.rows.count).End(xlUp).row
arrJK = sh.Range("J2:K" & reconRows).value
arrS = sh.Range("S2:S" & reconRows).value
'Checks that the new data has both an assigned and detected role and adds "No Issue" to column Q if valid.
For i = 1 To UBound(arrJK)
If arrJK(i, 1) <> "Not Found" And arrJK(i, 2) <> "" Then
arrS(i, 1) = "No Issue"
End If
Next i
sh.Range("S2").Resize(UBound(arrS), 1).value = arrS
End Sub
But in the code comment you mention "No Issue" to column Q" and in your code you use S:S column. Please, adapt if the return must be done in Q:Q.
Want to test this method and see the speed of looping with arrays compared to rows?
Dim timmy, i As Long, rc As Long, arr1, arr2, arr3
timmy = Timer
With Sheets(1)
rc = .Range("A" & Rows.Count).End(xlUp).Row
arr1 = .Range("J2:J" & rc).Value
arr2 = .Range("K2:K" & rc).Value
ReDim arr3(1 To UBound(arr1), 1 To 1)
For i = 1 To UBound(arr1, 1)
If arr1(i, 1) = "Not Found" And IsEmpty(arr2(i, 1)) Then
arr3(i, 1) = ""
Else
arr3(i, 1) = "No Issue"
End If
Next i
.Range("S2:S" & rc).Value = arr3
End With
Debug.Print "Loopy", Timer - timmy
Loop Through Arrays Instead of Ranges
To speed up a loop, you can turn off the three most common 'speed-related' application settings: ScreenUpdating, Calculation, and EnableEvents. Often it doesn't help much.
The trick is to access the worksheet as few times as possible i.e. to write the values of the ranges to arrays (you could think of these 2D one-based arrays as ranges (in this case column ranges) in memory, starting in row 1, since they are handled similarly), loop over the arrays and write the results to another (resulting) array and write the values from the latter array to the resulting range.
The first code, the array code, took roughly 0.3 seconds for 100.000 rows of simple sample data (created with the PopulateRandomData procedure) resulting in about 25.000 No Issue cells.
For the same data, the second code, the range code, took roughly 2.5 seconds when the resulting (destination) column range was cleared previously. It took about 5 seconds if each cell was cleared in the loop (a mistake). It took 40 seconds if vbNullString or Empty were written in the loop (a huge mistake).
So the array code was roughly 8 times faster but depending on your data and how the code was previously written, the array code could be many more (tens or even hundreds of) times faster.
Note that the running times will be different for your data so your feedback is appreciated.
Check out these Excel Macro Mastery videos to quickly learn about arrays and their use to speed up code.
Option Explicit
Sub DetectedCheckArray()
' Constants
Const wsID As Variant = 1 ' safer is to use the (tab) name, e.g. "Sheet1"
Const fRow As Long = 2
Const lrCol As String = "A" ' Last Row Column
Const c1Col As String = "J" ' 1st Criteria Column
Const c2Col As String = "K" ' 2nd Criteria Column
Const NotCrit1 As String = "Not Found" ' 1st Criteria
Const NotCrit2 As String = "" ' 2nd Criteria
Const dCol As String = "S" ' Destination Column
Const dString As String = "No Issue"
' If you use constants at the beginning of the code,
' you can easily change their values in one place without
' searching in the code.
' Reference the workbook ('wb').
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Reference the worksheet ('ws') (in the workbook).
Dim ws As Worksheet: Set ws = wb.Worksheets(wsID) '
' Calculate the last row ('lRow'),
' the row of the last non-empty cell in the column.
Dim lRow As Long: lRow = ws.Cells(ws.Rows.Count, lrCol).End(xlUp).Row
' Calculate the number of rows ('rCount').
Dim rCount As Long: rCount = lRow - fRow + 1
' Note that all ranges and arrays have this number of rows ('rCount').
' Validate the number of rows.
If rCount < 1 Then
MsgBox "No data in column range.", vbCritical
Exit Sub
End If
' Reference the last row (one-column) range ('lrrg') to be used
' to easily reference the remaining ranges.
Dim lrrg As Range
' This may be more understandable (commonly used),...
Set lrrg = ws.Range(ws.Cells(fRow, lrCol), ws.Cells(lRow, lrCol))
' ... but I prefer:
'Set lrrg = ws.Cells(fRow, lrCol).Resize(rCount)
' Reference the criteria (one-column) ranges ('crg1' and 'crg2').
Dim crg1 As Range: Set crg1 = lrrg.EntireRow.Columns(c1Col)
Dim crg2 As Range: Set crg2 = lrrg.EntireRow.Columns(c2Col)
' If you have a reference to a one-column range ('lrrg') and you want
' to reference the same range in another worksheet column ('c1Col, c2Col'),
' use '.EntireRow' to easily do it, to not complicate with '.Offset'.
' The code so far runs in split seconds.
' The following is the improvement.
' Start measuring the time passed.
Dim dt As Double: dt = Timer
' Write the values from the criteria ranges
' to 2D one-based one-column arrays ('cData1' and 'cData2').
Dim cData1() As Variant
Dim cData2() As Variant
If rCount = 1 Then ' one cell
ReDim cData1(1 To 1, 1 To 1): cData1(1, 1) = crg1.Value
ReDim cData2(1 To 1, 1 To 1): cData1(1, 1) = crg2.Value
Else ' multiple cells
cData1 = crg1.Value
cData2 = crg2.Value
End If
' Define the destination string array ('dsData').
Dim dsData() As String: ReDim dsData(1 To rCount, 1 To 1)
Dim r As Long
' Loop through the rows ('r') of the arrays and for each row
' check the values of the criteria arrays against the (not) criterias.
' If all (both) conditions are met, write the destination string ('dString')
' to the current row of the destination string array.
For r = 1 To rCount
If StrComp(CStr(cData1(r, 1)), NotCrit1, vbTextCompare) <> 0 Then
If StrComp(CStr(cData2(r, 1)), NotCrit2, vbTextCompare) <> 0 Then
dsData(r, 1) = dString
End If
End If
Next r
' Reference the destination (one-column) range ('drg').
Dim drg As Range: Set drg = lrrg.EntireRow.Columns(dCol)
' Write the values from the destination string array
' to the destination range.
drg.Value = dsData
' Inform.
MsgBox "Finished in " & Timer - dt & " seconds.", vbInformation
End Sub
Sub DetectedCheckRange()
' Constants
Const wsID As Variant = 1 ' safer is to use the (tab) name, e.g. "Sheet1"
Const fRow As Long = 2
Const lrCol As String = "A" ' Last Row Column
Const c1Col As String = "J" ' 1st Criteria Column
Const c2Col As String = "K" ' 2nd Criteria Column
Const NotCrit1 As String = "Not Found" ' 1st Criteria
Const NotCrit2 As String = "" ' 2nd Criteria
Const dCol As String = "S" ' Destination Column
Const dString As String = "No Issue"
' If you use constants at the beginning of the code,
' you can easily change their values in one place without
' searching in the code.
' Reference the workbook ('wb').
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Reference the worksheet ('ws') (in the workbook).
Dim ws As Worksheet: Set ws = wb.Worksheets(wsID) '
' Calculate the last row ('lRow'),
' the row of the last non-empty cell in the column.
Dim lRow As Long: lRow = ws.Cells(ws.Rows.Count, lrCol).End(xlUp).Row
' Calculate the number of rows ('rCount').
Dim rCount As Long: rCount = lRow - fRow + 1
' Note that all ranges and arrays have this number of rows ('rCount').
' Validate the number of rows.
If rCount < 1 Then
MsgBox "No data in column range.", vbCritical
Exit Sub
End If
' Reference the last row (one-column) range ('lrrg') to be used
' to easily reference the remaining ranges.
Dim lrrg As Range
' This may be more understandable (commonly used),...
Set lrrg = ws.Range(ws.Cells(fRow, lrCol), ws.Cells(lRow, lrCol))
' ... but I prefer:
'Set lrrg = ws.Cells(fRow, lrCol).Resize(rCount)
' Reference the criteria (one-column) ranges ('crg1' and 'crg2').
Dim crg1 As Range: Set crg1 = lrrg.EntireRow.Columns(c1Col)
Dim crg2 As Range: Set crg2 = lrrg.EntireRow.Columns(c2Col)
' If you have a reference to a one-column range ('lrrg') and you want
' to reference the same range in another worksheet column ('c1Col, c2Col'),
' use '.EntireRow' to easily do it, to not complicate with '.Offset'.
' Reference the destination (one-column) range ('drg').
Dim drg As Range: Set drg = lrrg.EntireRow.Columns(dCol)
' The code so far runs in split seconds.
' The following loop is what is slowing down the code.
' Start measuring the time passed.
Dim dt As Double: dt = Timer
' Turn off application settings to speed up.
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
drg.ClearContents ' or drg.clear (2.5 seconds)
Dim r As Long
' Loop through the rows ('r') of the column ranges and for each row
' check the values of the criteria ranges against the (not) criterias.
' If all (both) conditions are met, write the destination string ('dString')
' to the current row of the destination column.
For r = 1 To rCount
If StrComp(CStr(crg1.Cells(r).Value), NotCrit1, vbTextCompare) <> 0 Then
If StrComp(CStr(crg2.Cells(r).Value), NotCrit2, vbTextCompare) _
<> 0 Then
drg.Cells(r).Value = dString
Else ' The following line may or may not be necessary.
' Mistake, clear the complete range before (5 seconds).
'drg.Cells(r).Clear ' Contents ' or drg.Cells(r).Clear
' Huge mistake, use clear instead (40 seconds).
'drg.Cells(r).Value = Empty
'drg.Cells(r).Value = vbNullString
End If
End If
Next r
' Turn on application settings.
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
' Inform.
MsgBox "Finished in " & Timer - dt & " seconds.", vbInformation
End Sub
Sub PopulateRandomData()
Const rCount As Long = 100000
With ThisWorkbook.Worksheets(1)
.UsedRange.Clear
.Range("C:H,M:Q").EntireColumn.Hidden = True
With .Range("A2").Resize(rCount)
.Cells(1).Offset(-1).Value = "LrCol"
.Value = .Worksheet.Evaluate("ROW(1:" & CStr(rCount + 1) & ")")
.EntireColumn.AutoFit
End With
With .Range("J2").Resize(rCount)
.Cells(1).Offset(-1).Value = "Criteria1"
.Formula = "=CHOOSE(RANDBETWEEN(1,2),""Found"",""Not Found"")"
.Value = .Value
.EntireColumn.AutoFit
End With
With .Range("K2").Resize(rCount)
.Cells(1).Offset(-1).Value = "Criteria2"
.Formula = "=CHOOSE(RANDBETWEEN(1,2),""String"","""")"
.Value = .Value
.EntireColumn.AutoFit
End With
With .Range("S1")
.Value = "Result No Issue"
.EntireColumn.AutoFit
End With
End With
End Sub
I'm new to coding with VBA, and a beginner programmer in general. I have the following simple table (the data keeps getting inputted on daily basis, so it changes):
Item #
Description
Date
Location
Plate
Load
Type
Rate
Cost
0001
des1
30/1/21
Site
ABC123
5
One
typ1
100
0002
des2
30/1/21
Office
ACB465
4
One
typ1
100
0003
des3
30/1/21
Office
ABC789
3
One
typ1
100
0004
des4
30/1/21
Site
ABS741
5
One
typ1
100
0005
des4
31/1/21
Office
ABC852
2
One
typ1
100
I would like to filter this data by specific date first, then delete duplicates in Location while adding the Load for said duplicates.
For example, if I wanted to filter for 30/1/21. It would end up as follows:
Location
Load
Site
10
Office
7
I would then want to put it in one summary cell as follows:
Summary
10 Site, 7 Office
I was able to filter the original table into jagged arrays. The code for that is:
For j = numberSkipD To numberRowsD
If Worksheets("Disposal Fees").Range("F" & j).Value = Worksheets("Daily Tracking").Range("B2").Value Then
For k = numberDisposalInformationRaw To numberDisposalLocation
ReDim Preserve disposalLocation(numberDisposalLocation)
disposalLocation(numberDisposalLocation) = Worksheets("Disposal Fees").Range("I" & j).Value
Next
numberDisposalLocation = numberDisposalLocation + 1
For k = numberDisposalInformationRaw To numberDisposalLoad
ReDim Preserve disposalLoad(numberDisposalLoad)
disposalLoad(numberDisposalLoad) = Worksheets("Disposal Fees").Range("K" & j).Value
Next
numberDisposalLoad = numberDisposalLoad + 1
End If
Next
I then tried to do the second table above (deleting duplicates and adding the values for said duplicates together) but it is giving me errors, not sure how to solve them. I know they're index errors, but don't know how to fix them. (Please help me with this part, here is the code)
Dim disposalInformationRaw As Variant
Dim disposalInformationCooked As Variant
Dim FoundIndex As Variant, MaxRow As Long, m As Long
ReDim disposalInformationCooked(1 To UBound(disposalInformationRaw, 1), 1 To UBound(disposalInformationRaw, 2))
MaxRow = 0
For m = 1 To UBound(disposalInformationRaw, 1)
FoundIndex = Application.Match(disposalInformationRaw(m, 1), Application.Index(disposalInformationCooked, 0, 1), 0)
If IsError(FoundIndex) Then
MaxRow = MaxRow + 1
FoundIndex = MaxRow
disposalInformationCooked(FoundIndex, 1) = disposalInformationRaw(m, 1)
End If
disposalInformationCooked(FoundIndex, 2) = Val(disposalInformationCooked(FoundIndex, 2)) + Val(disposalInformationRaw(i, 2))
Next m
Range("G1").Resize(MaxRow, UBound(disposalInformationCooked, 2)).Value = disposalInformationCooked
I don't think I'd have much trouble finalizing the third part (the summary), but if you know how to do it, please feel free to share how you would approach it. I mostly need help with the second part. I would be more than happy to edit and provide more information if needed. Thanks in advance.
Here's one approach using a dictionary.
dim dict, rw as range, locn, k, msg, theDate
set dict= createobject("scripting.dictionary")
theDate = Worksheets("Daily Tracking").Range("B2").Value
'adjust table range as required
for each rw in worksheets("Disposal Fees").range("F6:K100").rows
if rw.cells(3).Value = theDate Then 'date match?
locn = rw.cells(4).Value 'read location
dict(locn) = dict(locn) + rw.cells(6).Value 'add load to sum
end if
next rw
'loop over the dictionary keys and build the output
for each k in dict
msg = msg & IIf(len(msg) > 0, ", ", "") & dict(k) & " " & k
next k
debug.print msg
Sum Unique
Disposal Fees
Daily Tracking
Adjust the values in the constants section.
The Code
Option Explicit
Sub TESTsumByValue()
' Source
Const srcName As String = "Disposal Fees"
Const lCol As Long = 3
Const kCol As Long = 4
Const sCol As Long = 6
Const SumFirst As Boolean = True
Const KSDel As String = ":"
Const IDel As String = ", "
' Destination
Const dstName As String = "Daily Tracking"
' Define workbook.
Dim wb As Workbook: Set wb = ThisWorkbook ' Workbook containing this code.
' Define Source Range (You may have to do something different).
Dim srg As Range: Set srg = wb.Worksheets(srcName).Range("A1").CurrentRegion
' Write Criteria to variable.
Dim drg As Range: Set drg = wb.Worksheets(dstName).Range("B2")
Dim Criteria As Variant: Criteria = drg.Value
' Use function to get the result.
Dim s As String
s = sumByValue(Criteria, srg, lCol, kCol, sCol, SumFirst, KSDel, IDel)
Debug.Print s ' "10:Site, 4:Bathroom, 4:Office"
drg.Offset(, 3).Value = s ' writes to 'E2'
End Sub
Function sumByValue( _
ByVal LookupValue As Variant, _
rng As Range, _
ByVal LookupColumn As Long, _
ByVal KeyColumn As Long, _
ByVal SumColumn As Long, _
Optional ByVal SumFirst As Boolean = False, _
Optional ByVal KeySumDelimiter As String = ": ", _
Optional ByVal ItemsDelimiter As String = ", ") _
As String
' Validate range ('rng').
If rng Is Nothing Then Exit Function
' Write values from range to Data Array ('Data').
Dim Data As Variant: Data = rng.Value ' 2D one-based array
' Declare additional variables.
Dim vKey As Variant ' Current Key Value
Dim vSum As Variant ' Current Sum Value
Dim i As Long ' Data Array Row Counter
' Create a reference to Unique Sum Dictionary (no variable).
With CreateObject("Scripting.Dictionary")
.CompareMode = vbTextCompare ' 'A = a'
' Loop through Data Array ('Data') and write and sumup unique values
' to Unique Sum Dictionary.
For i = 1 To UBound(Data, 1)
If Data(i, LookupColumn) = LookupValue Then
vKey = Data(i, KeyColumn)
If Not IsError(vKey) Then
If Len(vKey) > 0 Then
vSum = Data(i, SumColumn)
If IsNumeric(vSum) Then
.Item(vKey) = .Item(vKey) + vSum
Else
.Item(vKey) = .Item(vKey) + 0
End If
End If
End If
End If
Next i
' Validate Unique Sum Dictionary.
If .Count = 0 Then Exit Function
' Redefine variables to be reused.
ReDim Data(1 To .Count) ' Result Array: 1D one-based array
i = 0 ' Result Array Elements Counter
' Write results to Result Array.
If SumFirst Then
For Each vKey In .Keys
i = i + 1
Data(i) = .Item(vKey) & KeySumDelimiter & vKey
Next vKey
Else
For Each vKey In .Keys
i = i + 1
Data(i) = vKey & KeySumDelimiter & .Item(vKey)
Next vKey
End If
End With
' Write the elements of Data Array to Result String.
sumByValue = Join(Data, ItemsDelimiter)
End Function
I've spent hours trying to find out how to join returned values from a named range, but the result is a
run-time error 32 - Type mismatch.
As a newbie I'm still struggling with arrays, so maybe I've overlooked some detail. Thank you for helping me out.
Example: (B1)Benzine, (B2)Diesel, (B3)Hybride -> (E1)Gasoline, (E2)Diesel, (E3)Hybrid
This is the named range:
Another example (to be more clear):
Example 2: (B1)Benzine, (B3)Hybride -> (E1)Gasoline, (E3)Hybrid
Option Explicit
Sub splitter()
Dim i As Long
Dim w As Long
'Dim oWB As Workbook
Dim oWS As Worksheet
Dim oWS9 As Worksheet
Dim rngMOTOR As Range
Dim rngMOTOR2 As Range
Dim arrMOTOR() As Variant
Dim LastRow As Long
'Set oWB = Workbooks("BRONBESTAND.xlsm")
Set oWS = Sheets("ONDERDELEN")
Set oWS9 = Sheets("MOTOR") '5 columns: 1 Short & LONG + 1 NL + 3 Languages !!!!! WARNING
LastRow = oWS.Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To LastRow 'Starting below headers
Set rngMOTOR = oWS.Cells(i, "M") 'MOTOR ...
Set rngMOTOR2 = oWS9.Range("MOTOR") 'MOTOR2: MOTOR - Bronbestand arrPOS = rngPOS2.Value
arrMOTOR = rngMOTOR2.Value
'*********
Dim txt As String
Dim j As Integer
Dim Splitted As Variant
Dim arrMOTORall As Variant
Dim arrMOTORsplit As Variant
Dim Motor3 As String
txt = oWS.Cells(i, "M") 'MOTOR ...
Debug.Print ("txt : ") & i & ": "; txt
If Not IsEmpty(txt) Then
Splitted = Split(txt, ", ")
For j = 0 To UBound(Splitted)
Cells(1, j + 1).Value = Splitted(j)
Debug.Print (" ---> Splitted: ") & Splitted(j)
'**** INSERT *****
For w = LBound(arrMOTOR) To UBound(arrMOTOR)
If arrMOTOR(w, 1) = Splitted(j) Then 'EX: B - Benzine
arrMOTORsplit = (arrMOTOR(w, 4)) '(arrMOTOR(y, 2)) -> 1=SHORT+LONG , 2=NL, 3=FR, 4=EN
Debug.Print (" ---> arrMOTORsplit: ") & i & ": " & arrMOTORsplit
'**** JOIN ****
arrMOTORall = Join(arrMOTORsplit, ", ")
Debug.Print ("arrMOTORall: ") & arrMOTORall
End If
Next w
Next j
End If
Next i
End Sub
Get comma separated strings for each column in named range
I didn't analyze your code, but this should work to receive the first three values joined
"Benzine, Diesel, Hybride" ' e.g. from first column
or
"Gasoline, Diesel, Hybrid" ' e.g. from the fourth column
from a named range "Motor" via the Application.Index function.
Notes
The parameter 0 in this Index function indicates to not choose a specific row, the Parameter ColNo chooses each of your columns in a Loop. A subsequent transposition allows to change the 2 dimensioned array values to a 1-dim array. The Join function needs a 1-dim array and concatenates the chosen column items therein.
Hint: The following sample code uses a fully qualified range reference assuming that you don't call the TestMe procedure from your Personal Macro Library. In the latter case you'd have to change references and workbook identification (not using ThisWorkbook!).
Example code
Option Explicit ' declaration head of your code module
Sub TestMe()
Dim v As Variant, ColNo As Long
' assign first three rows to variant 1-based 2-dim datafield array
v = ThisWorkbook.Worksheets("Motor").[Motor].Resize(3, 4) ' Named range value
' write comma separated list for each column
For ColNo = 1 To 4
Debug.Print Join(Application.Transpose(Application.Index(v, 0, ColNo)), ", ")
Next ColNo
End Sub
EDIT - Flexible Search in ANY ORDER to translate joined lists
This solution allows to return joined search words in any combination using the Application.Index function in an advanced way using row and column arrays as parameters. The main function getSplitters() creates a variant 2-dim array in only three steps without loops and redims and uses two language constants (Const DUTCH and Const ENGLISH).:
assigns data to variant 1-based 2-dim datafield array
gets only the selected rows based on comma separated string values
reduces the same array to Dutch and English columns
Calling Code
Due to your OP the calling code anylyzes all comma separated strings in Column M in your sheet "ONDERDELEN" as far as there are values in column A. This is made by passing these found string values to the main function getSplitters with an innovative approach to get results in only three steps without Loops (see function code below).
Translation is based on values in the named range Motor "B1:E4" in sheet "Motor" where rows comprise different sort of fuel with neighbouring columns for different languages (starting with Dutch in the first column and English in the fourth col).
Note that using VBA it is faster to loop through an array to get values than through a range.
Option Explicit ' declaration head of your code module
Const DUTCH As Integer = 1
Const ENGLISH As Integer = 4
Sub TranslateAnyFuelCombination()
' Purpose: returns comma separated lists in column "M" and translates from Dutch to English
' Example: "Benzine, Hybride, Diesel" (Dutch) gets to "Gasoline, Hybrid, Diesel" in English
Dim s As String
Dim oWS As Worksheet, i&, LastRow&, vMOTOR As Variant
Set oWS = Thisworkbook.Worksheets("ONDERDELEN") ' fully qualified reference
' Get last row of wanted data
LastRow = oWS.Range("A" & Rows.Count).End(xlUp).Row
vMOTOR = oWS.Range("M1:M" & LastRow)
For i = 2 To LastRow 'Starting below headers
Debug.Print getSplitters(vMOTOR(i, 1))
Next i
End Sub
Main function
Function getSplitters(ByVal sRows As String) As String
Dim i As Long, j As Long
Dim v As Variant, a As Variant
' [0] analyze selected rows string, e.g. "Benzine, Hybride, Diesel"
a = getRowAr(sRows) ' -> assign 1-dim Rows Array(1, 3, 2)
' [1] assign data to variant 1-based 2-dim datafield array
v = Application.Transpose(ThisWorkbook.Worksheets("Motor").[Motor]) ' Named range value
' [2] get only selected rows, e.g. 1st, 3rd and 2nd -> in free order (!) Benzine, Hybride, Diesel
v = Application.Transpose(Application.Index(v, _
Application.Evaluate("row(1:" & UBound(v, 2) & ")"), _
a)) ' transposed columns array = selected rows
' [3] reduce to Dutch and English columns
v = Application.Transpose(Application.Index(v, _
Application.Evaluate("row(1:" & (UBound(a) + 1) & ")"), _
Array(DUTCH, ENGLISH))) ' selected columns array (above array retransposed)
' [4] return concatenated strings
getSplitters = Join(Application.Transpose(Application.Transpose(Application.Index(v, 1, 0))), ", ") & " -> " & _
Join(Application.Transpose(Application.Transpose(Application.Index(v, 2, 0))), ", ")
End Function
Two helper functions
Function getRowAr(ByVal sList As String) As Variant
' Purpose: split comma separated list into 1-dim number array in FREE ORDER
' Example: "Benzine, Hybride, Diesel" -> Array(1, 3, 2)
Dim ar, i&
' change words in comma separated list to numbers
ar = Split(Replace(sList, " ", ""), ",")
For i = LBound(ar) To UBound(ar)
ar(i) = val(getNumber(ar(i))) ' change to numbers
Next i
getRowAr = ar ' return
End Function
Function getNumber(ByVal s As String) As Long
' Purpose: replaces dutch search words with corresponding row number
Dim arFuel
' get search words to 1-dim array
arFuel = Application.Index(ThisWorkbook.Worksheets("Motor").[Motor], 0, DUTCH)
' return corresponding number
getNumber = Application.Match(s, arFuel)
End Function
Addendum (Edit due to comment)
The above code works as intended if you are sure that the concatenated search words (or starting parts) actually match else an Error 13 is raised. You can solve this issue in two steps:
Insert an empty first row into your named range Motor (or fill it e.g. with ?, #N/A etc.)
Change the 2nd helper function as follows:
Edited function getNumber()
Function getNumber(ByVal s As String) As Long
' Purpose: replaces dutch search words with corresponding row number
Dim arFuel
' get search words to 1-dim array
arFuel = Application.Index(ThisWorkbook.Worksheets("Motor").[Motor], 0, DUTCH)
' return corresponding number
On Error Resume Next ' provide for not found case
getNumber = Application.Match(s, arFuel, 0) ' find only exact matches
If Err.Number <> 0 Then getNumber = 0 ' could be omitted in case of a zero return
End Function
With 2 arrays this is a possible solution:
Sub TestMe()
Dim inputString As String
Dim arrString As Variant
Dim arrResult As Variant
inputString = "Benzine, Diesel, Hybride"
arrString = Split(inputString, ",")
Dim total As Long: total = UBound(arrString)
ReDim arrResult(total)
Dim i As Long
For i = LBound(arrString) To UBound(arrString)
arrResult(total - i) = Trim(arrString(i))
Next i
Debug.Print Join(arrResult, " ,")
End Sub
However, there is a classic solution of this problem, reversing everything twice:
Sub TestMe()
Dim inputString As String
inputString = "Benzine, Diesel, Hybride"
inputString = StrReverse(inputString)
Dim arr As Variant: arr = Split(inputString, ",")
Dim i As Long
For i = LBound(arr) To UBound(arr)
arr(i) = Trim(StrReverse(arr(i)))
Next i
Debug.Print Join(arr, ", ")
End Sub
Task
My intention is to write back UserForm Listbox data to a sheet range in the most efficient way using the data field method.
Basic Method (esp. using data ranges)
AFAIK the most efficient method in order to write data to a range is using arrays. If data originate from a range it's preferrable to use data field arrays, which by default are two dimensional (one based arrays) and allow to
a) get data from sheet to array or
b) write back the array to sheet
with one code line:
Dim v ' As Variant
Dim rng As Range
Set rng = ...
' a) range to array
v = rng.Value
' b) array to range
rng.Value = v
Differences when using the ListBox data array
ListBox data are stored in a 2dim, but zero based array, e.g. ListBox1.List
[Hint: Therefore it's possible to create items using a predefined array instead of using the commonly known Add method, BTW restricted to only 10 columns (indexed 0 to 9). ]
Despite this difference, it is possible to read in the ListBox data and write them back to sheet with the described basic method:
' aa) ListBox data to array
v = Me.ListBox1.List
' bb) array to range
rng.Value = v
Furthermore, I remarked that by default the array columns count 10, so this won't correspond to the programmatically set ColumnCount. Therefore it's necessary to adapt the range checking the array dimensions, cf. debug protocol in the code example.
Problem and work around
Writing back the data field array to sheet in an one liner raises error 1004 (Application-defined or object-defined error) if there are items with a leading "==" string or comparable user inputs, as this can't be interpreted correctly by Excel.
My attempt to use
rng.Text = v
instead of
rng.value = v
did fail, too, causing a 424 object needed error.
Question
==> Is it possible to correct the potential error items with leading "=" character without looping through all array items using VBA or API methods? Any Code example is welcome to replace my work around (step 3 in code)
My Code
My code consists of four steps
1) create a 2dim data field array (v)
2) set a target range (rng)
3) [my work around correcting each array item]
4) write data back to worksheet
Private Sub CommandButton1_Click()
' declare variables
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Dump")
Dim s As String ' range address string
Dim sTest As String ' item test string
Dim v As Variant ' data field array
Dim rng As Range ' (target) range
Dim i As Long ' rows counter
Dim j As Long ' columns counter
Dim R As Long ' number of rows
Dim C As Integer ' number of columns
Dim lbxR As Long ' actual number of listbox items in data field
Dim lbxC As Integer ' actual number of listbox columns in data field
' Error Handler
On Error GoTo OOPS
' get programmatically defined listbox dimension
R = Me.ListBox1.ListCount
C = Me.ListBox1.ColumnCount
' clear sheet lines A2:A{r}
ws.Range(ws.Cells(2, 1), ws.Cells(R, C)).value = ""
' ===============================
' 1) create 2dim data field array
' -------------------------------
v = Me.ListBox1.List
' -------------------------------
' 2) set target range (rng)
' -------------------------------
' get actual data field dimension
lbxR = UBound(v, 1) - LBound(v, 1) + 1 ' first dimension
lbxC = UBound(v, 2) - LBound(v, 2) + 1 ' second dimension
s = ws.Range("A2").Resize(lbxR, lbxC).Address
' set correconding target range
Set rng = ws.Range(s) ' target range
' create short protocol - columns by default differ from user defined ColumnCount property !
Debug.Print String(80, "-")
Debug.Print vbNewLine & "** ListBox1 Defs Data Field Array Dimension **"
Debug.Print " [Target Range " & s & "]"
Debug.Print String(80, "-")
Debug.Print " ListCount = " & ListBox1.ListCount, "rows = " & lbxR & " = ubound(v,1)-lbound(v,1)+1 = " & UBound(v, 1) & " - " & LBound(v, 1) & " + 1 "
Debug.Print " ColumnCount= " & ListBox1.ColumnCount, "cols = " & lbxC & " = ubound(v,2)-lbound(v,2)+1 = " & UBound(v, 2) & " - " & LBound(v, 2) & " + 1 "
Debug.Print String(80, "-")
' ----------------------------------------------------------------
' 3) Work around - correct leading "=", if any occurences presumed
' (avoid error 1004 - App-defined or object-defined error)
' ----------------------------------------------------------------
' ==> Is there an alternative way?
' For i = 0 To R - 1 ' edited thx to D.Lee
' For j = 0 To C - 1
' v(i, j) = IIf(Left(Me.ListBox1.List(i, j) & "", 1) = "=", " ", "") & _
' Me.ListBox1.List(i, j)
' Next j
' Next i
' -------------------------------
' 4) write data back to worksheet
' -------------------------------
rng.value = v
Exit Sub
' =============
' Error Handler
' =============
OOPS:
MsgBox "ERL=" & Erl & " |Error " & Err.Number & "|" & Err.Description & vbNewLine & _
"s=" & s, vbExclamation
End Sub
Tip I recommend reading "Arrays and Ranges in VBA" by C.Pearson
Addendum to OP from Sep 17 '17(alternative solution)
If you know for example that the first target column is text only, you can code the following statement before section [4] instead of searching for each list item starting with =:
rng.Columns(1).NumberFormat = "#"
Lbound(v,1) = 0 ubound(v,1) = r-1
so, it needs to modify i and j.
For i = 0 To R - 1
For j = 0 To C - 1
v(i, j) = IIf(Left(Me.ListBox1.List(i, j) & "", 1) = "=", " ", "") & _
Me.ListBox1.List(i, j)
Next j
Next i