I made a function that will convert almost anything to a string, including a multi-dimensional array!
'example1:
Debug.Print fStr(array(1 to 2, 1 to 2)) '>>> (("11","21"),("21","12"))
'example2:
ReDim arr(1 To 2, 1 To 3) As Variant
arr(1, 1) = "11" & Chr(13)
arr(2, 1) = 21
arr(1, 2) = Array(Null, 1)
arr(2, 2) = True
Set arr(1, 3) = ActiveCell
Set arr(2, 3) = Nothing
Debug.Print fStr(arr) '>>> (("11[13]",21),((Null,1),True),(Sheet1!A1,Nothing))
Now I want to reverse it, but I can't find a way to Dim or Redim a multi-dimensional array that could have 1 up to 6000 dimensions!
The amount of "(" at the beginning of the string tells how many dimensions, but I don't want to add 6000 lines with each line having a Redim with one more dimension!
So how can I use a variable as the Redim multi-dimensional parameter ???
So I need to find a solution that looks like this:
d="1 to 2, 1 to 3"
Redim arr(d)
or like this:
fReDim "1 to 2", "1 to 3"
Sub fReDim (ParamArray d() As string)
Redim arr(d())
end Sub
Any help appreciated, thank you.
Oh yeah, for those that are looking for a function that converts anything to a string...
'example1:
Debug.Print fStr(array(1 to 2, 1 to 2)) '>>> (("11","21"),("21","12"))
'example2:
ReDim arr(1 To 2, 1 To 3) As Variant
arr(1, 1) = "11" & Chr(13)
arr(2, 1) = 21
arr(1, 2) = Array(Null, 1)
arr(2, 2) = True
Set arr(1, 3) = ActiveCell
Set arr(2, 3) = Nothing
Debug.Print fStr(arr) '>>> (("11[13]",21),((Null,1),True),(Sheet1!A1,Nothing))
Now I want to reverse it, but I can't find a way to Dim or Redim a multi-dimensional array that could have 1 up to 6000 dimensions!
The amount of "(" at the beginning of the string tells how many dimensions, but I don't want to add 6000 lines with each line having a Redim with one more dimension!
So how can I use a variable as the Redim multi-dimensional parameter ???
So I need to find a solution that looks like this:
d="1 to 2, 1 to 3"
Redim arr(d)
or like this:
fReDim "1 to 2", "1 to 3"
Sub fReDim (ParamArray d() As string)
Redim arr(d())
end Sub
Any help appreciated, thank you.
Oh yeah, for those that are looking for a function that converts anything to a string...
Code:
Private Sub test_fStr(Optional oMissing)
Dim emptyArr() As Variant, dim3Arr(0, 2, 1)
Dim arr() As Variant
ReDim arr(1 To 2, 1 To 3, 1 To 2)
For i3 = 1 To UBound(arr, 3) [COLOR=#00A000]'''filling array[/COLOR]
For i2 = 1 To UBound(arr, 2)
For i1 = 1 To UBound(arr, 1)
arr(i1, i2, i3) = Val(i1 & i2 & i3)
Next
Next
Next
Debug.Print fStr(arr) [COLOR=#00A000]'''=(((111,211),(121,221),(131,231)),((112,212),(122,222),(132,232)))[/COLOR]
Debug.Print fStr(arr, , " ", "") [COLOR=#00A000]'''=111 211 121 221 131 231 112 212 122 222 132 232[/COLOR]
ReDim arr(1 To 2, 1 To 3) As Variant
arr(1, 1) = "11" & Chr(13)
arr(2, 1) = 21
arr(1, 2) = Array(Null, 1)
arr(2, 2) = True
Set arr(1, 3) = ActiveCell
Set arr(2, 3) = Nothing
Debug.Print fStr(arr) [COLOR=#00A000]'''=(("11[13]",21),((Null,1),True),(Sheet1!A1,Nothing))[/COLOR]
Debug.Print fStr(Array(1, "x""y""z", 2)) [COLOR=#00A000]'''(1,"2",Nothing,Empty,Null,True,[Sheet1!B16])[/COLOR]
Debug.Print fStr(Array(1, "2", , , True, ActiveCell)) [COLOR=#00A000]'''(1,"2",Nothing,Empty,Null,True,[Sheet1!B16])[/COLOR]
Debug.Print fStr(emptyArr) [COLOR=#00A000]'''=(Unallocated)[/COLOR]
Debug.Print fStr(oMissing) [COLOR=#00A000]'''=Missing[/COLOR]
Debug.Print fStr(Nothing) [COLOR=#00A000]'''=Nothing[/COLOR]
Debug.Print fStr(Empty) [COLOR=#00A000]'''=Empty[/COLOR]
Debug.Print fStr(Null) [COLOR=#00A000]'''=Null[/COLOR]
Debug.Print fStr(ActiveCell) [COLOR=#00A000]'''=Sheet1!$A$1[/COLOR]
Debug.Print fStr(ActiveSheet) [COLOR=#00A000]'''=Sheet1[/COLOR]
Debug.Print fStr(ActiveWorkbook) [COLOR=#00A000]'''=filename.xlsm[/COLOR]
Debug.Print fStr(ActiveWindow) [COLOR=#00A000]'''=filename.xlsm[/COLOR]
Debug.Print fStr(Application) [COLOR=#00A000]'''=Microsoft Excel[/COLOR]
Debug.Print fStr(True) [COLOR=#00A000]'''=True[/COLOR]
Debug.Print fStr(123) [COLOR=#00A000]'''=123[/COLOR]
Debug.Print fStr("123") [COLOR=#00A000]'''="123"[/COLOR]
Debug.Print fStr("123", False) [COLOR=#00A000]'''=123[/COLOR]
Debug.Print fStr("") [COLOR=#00A000]'''=""[/COLOR]
Debug.Print fStr("x" & Chr(13) & "x") [COLOR=#00A000]'''="x[13]x"[/COLOR]
Debug.Print fStr("x" & Chr(13) & "x", , , , "<>") [COLOR=#00A000]'''="x<13>x"[/COLOR]
End Sub
Function fStr(xAnything, Optional bAddQuotes = True, Optional vDelimiter = ",", Optional vMarkers = "()", Optional vAscII = "[]") As String [COLOR=#00A000]'''24/08/2013, michel(dot)be(a)gmail....[/COLOR]
[COLOR=#00A000]'''Converts almost anything to a string,[/COLOR]
[COLOR=#00A000]'''including (multi-dimensional and/or multi-level) arrays using delimiters and markers for backwards compatibility.[/COLOR]
[COLOR=#00A000]'''Can be used to debug.print or compare anything without errors.[/COLOR]
[COLOR=#00A000]'''Can return string, "string", 123, [asc], False, True, Empty, Missing, Nothing, Null, object-name, object-address, ((*,*),(*,*)) ...[/COLOR]
[COLOR=#00A000]''' bAddQuotes True to add Quotes around strings, do distinguish strings with numbers or anything else[/COLOR]
[COLOR=#00A000]''' vDelimiter Use the character or string between every data in the array[/COLOR]
[COLOR=#00A000]''' vMarkers Use left and right character around arrays and every dimensioned group in them[/COLOR]
[COLOR=#00A000]''' vAscII Change special characters in [asc-code] as [13] = enter[/COLOR]
Dim vTemp As String, dimMarker() As String, i As Integer, xData As Variant
If isMissing(xAnything) Then [COLOR=#00A000]'''would otherwise return Error 448[/COLOR]
fStr = "Missing"
ElseIf isNothing(xAnything) Then
fStr = "Nothing"
ElseIf IsObject(xAnything) Then
On Error Resume Next
fStr = xAnything.Caption [COLOR=#00A000]'''maybe a window[/COLOR]
fStr = xAnything.Name [COLOR=#00A000]'''maybe a sheet or a workbook[/COLOR]
fStr = xAnything.Parent.Name & "!" & Replace(xAnything.Address, "$", "") [COLOR=#00A000]'''maybe a range[/COLOR]
On Error GoTo 0
ElseIf IsArray(xAnything) Then [COLOR=#00A000]'''array(1 to 2, 1 to 2) >>> ((11,21),(21,12))[/COLOR]
If Not isAllocated(xAnything) Then
fStr = "(Unallocated)"
Else
vTemp = Chr(1) [COLOR=#00A000]'''first create vMarkers using Chr(1) to replace later with data from the array[/COLOR]
For i = 1 To fArrDimNum(xAnything) [COLOR=#00A000]'''for every existing dimension duplicate the needed delimiters within vMarkers[/COLOR]
vTemp = Left(vMarkers, 1) & fRepeatStr(vTemp, fArrDimSize(xAnything, i), vDelimiter) & Right(vMarkers, 1)
Next
dimMarker = Split(vTemp, Chr(1)) [COLOR=#00A000]'''split vMarkers in an single array with enough elements to hold the data from the multi-dimensional array[/COLOR]
i = 0
For Each xData In xAnything [COLOR=#00A000]'''loop through all data in the array: (1,1,1), (2,1,1), (1,2,1), (2,2,1), (1,1,2), (2,1,2), ...[/COLOR]
If IsArray(xData) Then x = fStr(xData) [COLOR=#00A000]'''array in array found[/COLOR]
fStr = fStr & dimMarker(i) & fStr(xData, bAddQuotes) [COLOR=#00A000]'''adds the vDelimiter en vMarkers between the data converted to text[/COLOR]
i = i + 1
Next
fStr = fStr & dimMarker(i) [COLOR=#00A000]'''add the last marker[/COLOR]
End If
ElseIf IsEmpty(xAnything) Then
fStr = "Empty"
ElseIf IsNull(xAnything) Then [COLOR=#00A000]'''would otherwise return real Null, not "Null"[/COLOR]
fStr = "Null"
ElseIf isBoolean(xAnything) Then
fStr = xAnything
ElseIf isNumber(xAnything) Then
fStr = xAnything
Else [COLOR=#00A000]'''string[/COLOR]
For i = 1 To Len(xAnything)
vChr = Mid(xAnything, i, 1)
vASC = Asc(vChr)
If vAscII <> "" And (InStr(" 127 129 141 143 144 152 157 ", " " & vASC & " ") Or vASC < 32) Then
fStr = fStr & Left(vAscII, 1) & vASC & Right(vAscII, 1)
Else
fStr = fStr & vChr
End If
Next
If bAddQuotes Then fStr = Chr(34) & Replace(fStr, Chr(34), Chr(34) & Chr(34)) & Chr(34)
End If
End Function
[COLOR=#00A000]'''***************************** some included functions ******************************************[/COLOR]
Function fRepeatStr(vString, iTimes, Optional vDelimiter = "") As String [COLOR=#00A000]'''21/08/2013, michel(dot)be(a)gmail....[/COLOR]
For i = 1 To Int(Abs(Val(iTimes)))
fRepeatStr = fRepeatStr & addDelimiter & vString
addDelimiter = vDelimiter
Next i
End Function
Function fArrDimNum(xThis) As Integer [COLOR=#00A000]'''23/08/2013, michel(dot)be(a)gmail....[/COLOR]
[COLOR=#00A000]'''Returns amount of dimensions in an array, 0 for not allocated array and -1 if not a array[/COLOR]
Dim numDim As Integer
If isAllocated(xThis) Then
On Error GoTo endDim
For numDim = 1 To 6000 [COLOR=#00A000]'''VBA arrays can have up to 60000[/COLOR]
temp = UBound(xThis, numDim)
Next
ElseIf IsArray(xThis) Then
numDim = 1
End If
endDim:
fArrDimNum = numDim - 1
End Function
Function fArrDimSize(xThis, Optional iRank = 1) As Integer [COLOR=#00A000]'''23/08/2013, michel(dot)be(a)gmail....[/COLOR]
[COLOR=#00A000]'''Returns the size of 1 dimension in an array[/COLOR]
fArrDimSize = fUBound(xThis, iRank) - fLBound(xThis, iRank) + 1
End Function
Function fUBound(xArray, Optional iRank = 1) As Integer [COLOR=#00A000]'''23/08/2013, michel(dot)be(a)gmail....[/COLOR]
[COLOR=#00A000]'''Same af build-in UBound() but without errors on unallocated arrays[/COLOR]
If isAllocated(xArray, iRank) Then
fUBound = UBound(xArray, iRank)
Else
fUBound = -1
End If
End Function
Function fLBound(xArray, Optional iRank = 1) As Integer [COLOR=#00A000]'''23/08/2013, michel(dot)be(a)gmail....[/COLOR]
[COLOR=#00A000]'''Same af build-in LBound() but without errors on unallocated arrays[/COLOR]
If isAllocated(xArray, iRank) Then
fLBound = LBound(xArray, iRank)
Else
fLBound = 0
End If
End Function
[COLOR=#00A000]'''In the same line as IsEmpty, IsMissing, ...[/COLOR]
[COLOR=#00A000]'''remark: function-name starts with a lower-case "i" to show it is not standard VBA[/COLOR]
Function isAllocated(xThis, Optional iRank = 1) As Boolean [COLOR=#00A000]'''07/06/2013, michel(dot)be(a)gmail....[/COLOR]
If IsArray(xThis) Then
On Error Resume Next
isAllocated = LBound(xThis, iRank) <= UBound(xThis, iRank)
End If
End Function
Function isBoolean(xThis) As Boolean [COLOR=#00A000]'''07/06/2013, michel(dot)be(a)gmail....[/COLOR]
If TypeName(xThis) = "Boolean" Then
isBoolean = True
End If
End Function
Function isNumber(xThis) As Boolean [COLOR=#00A000]'''07/06/2013, michel(dot)be(a)gmail....[/COLOR]
[COLOR=#00A000]'''Because IsNumeric can be Empty, Null, Range, Boolean and in a string !!![/COLOR]
If "Decimal Double Integer Long LongLong Short SByte Single" Like "*" & TypeName(xThis) & "*" Then
isNumber = True
End If
End Function
Function isNothing(xThis) As Boolean [COLOR=#00A000]'''07/06/2013, michel(dot)be(a)gmail....[/COLOR]
[COLOR=#00A000]'''To be able to use "If isNothing(x) Then..." instead of "If x Is Nothing Then..."[/COLOR]
[COLOR=#00A000]'''Which is even better, because it doesn't return an error when x isn't an object.[/COLOR]
If TypeName(xThis) = "Nothing" Then
isNothing = True
End If
End Function