I've written a multi-dimensional Array to String, but need HELP to reverse it!

O

onidarbe

Board Regular
Joined
Mar 22, 2013
Messages
65
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!:confused:

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.

icon3.png

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
 

Excel Facts

Can you sort left to right?
To sort left-to-right, use the Sort dialog box. Click Options. Choose "Sort left to right"
Sort by date Sort by votes
You must log in or register to reply here.

Forum statistics

Threads
1,214,414
Messages
6,119,373
Members
448,888
Latest member
Arle8907

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top