Manipulate data in 1-dim array and copy it to a 2-dim array-CodePudding

I have a one-dimensional array with the values below and I want to turn the array in a two-dimensional one, cut the "/*" and save it in the second dimension. The result is supposed to look the second table. I'm trying to utilize a second array for this using the following code but for some reason I get the message that the types are incompatible in the line arr2(i, i) = Mid(arr1(i), 1, arrSffx).

Sub Test2()

    Dim arr1 As Variant
    Dim arr2 As Variant
    Dim i, j, arrSffx, arrLen As Long
      
    arr1 = getUniqueValuesFromRange(Worksheets("table1").UsedRange.Columns("A"))
    
    For i = 0 To UBound(arr1)
    
        arrSffx = InStrRev(arr1(i), "/")
        arrLen = Len(arr1(i))
    
        arr2(i, i) = Mid(arr1(i), 1, arrSffx)
        arr2(i, i   1) = Mid(arr1(i), arrSffx, arrLen - arrSffx)
                
    Next i
    
    For i = 0 To UBound(arr2)
    
        Worksheets("table1").Range("D" & i   2) = arr1(i, i)
        Worksheets("table1").Range("D" & i   2) = arr1(i, i   1)
    
    Next i
    
End Sub

CodePudding user response：

You can use this function

Public Function splitArray(arr As Variant, delimiter As String) As Variant
Dim arrReturn As Variant
ReDim arrReturn(UBound(arr), 1)

Dim i As Long, posDelimiter As Long
For i = LBound(arr) To UBound(arr)
    posDelimiter = InStr(arr(i), delimiter)
    arrReturn(i, 0) = Left(arr(i), posDelimiter - 1)
    arrReturn(i, 1) = Mid(arr(i), posDelimiter)
Next
splitArray = arrReturn
End Function

and use it like this


Sub Test2()

    Dim arr1 As Variant
    Dim arr2 As Variant
      
    arr1 = getUniqueValuesFromRange(Worksheets("table1").UsedRange.Columns("A"))
    arr2 = splitArray(arr1, "/")
    
    Dim rgTarget As Range
    Set rgTarget = Worksheets("table1").Range("D1")
    
    rgTarget.Resize(UBound(arr2, 1), 2).Value = arr2
        
End Sub

CodePudding user response：

Its easier if you let the built in functions of vba and other libraries (mscorlib) take the strain.

This solution uses the ArrayList object which can be found in the mscorlib library (add a reference to mscorlib).

It also uses the VBA 'Split' method which can be used to split a string into a number of substrings using a delimiter. In your case you need the delimiter added back to the second string.

Sub Test2()

    Dim myUniqueValues As ArrayList
    Set myUniqueValues = GetUniqueValuesFromRange(Worksheets("table1").UsedRange.Columns("A"))
    
    Dim myOutput As Variant
    ReDim myOutput(1 To myUniqueValues.Count, 1 To 2)
    
    Dim myTmp As Variant
    Dim myIndex As Long
    myIndex = 1
    Dim myItem As Variant
    For Each myItem In myUniqueValues
    
        myTmp = VBA.Split(myItem, "/")
        myOutput(myIndex, 1) = myTmp(0)
        myOutput(myIndex, 2) = "/" & myTmp(1)
        myIndex = myIndex   1
        
    Next
    
    Worksheets("table1").Range("D1:E" & CStr(myUniqueValues.Count)) = myOutput
    
End Sub

Public Function GetUniqueValuesFromRange(ByVal ipRange As Excel.Range) As ArrayList

    Dim myInputArray As Variant
    myInputArray = ipRange.Value
    
    Dim myAL As ArrayList
    Set myAL = New ArrayList
    
    Dim myItem As Variant
    For Each myItem In myInputArray
        If Not myAL.Contains(myItem) Then
            myAL.Add myItem
        End If
    Next
    
    Set GetUniqueValuesFromRange = myAL
    
End Function

CodePudding user response：

Here is heavily commented code on how to transform a 1 dimensional array into a 2 dimensional array by delimiter. The advantage of this method is that is that the result is not hard limited to 2 columns, it can be any number of columns:

'This function tranforms a 1 dimensional array to a 2 dimensional array
'Arguments:
'  arg_1D = A 1 dimensional array
'   Required
'  arg_sDelimiter = The delimiter to split elements on to create a 2 dimensional array
'   Optional
'   Default value is "/"
'  arg_bIncludeDelim = Boolean (True/False) value on whether to include the delimiter in the output results
'   Optional
'   Default is True
Function Transform_1D_to_2D_Array( _
    ByVal arg_a1D As Variant, _
    Optional ByVal arg_sDelimiter As String = "/", _
    Optional ByVal arg_bIncludeDelim As Boolean = True _
) As Variant
    
    'Verify passed argument is actually a 1 dimensional array
    If Not IsArray(arg_a1D) Then
        Exit Function   'argument is not an array
    Else
        Dim lTestExtraDimension As Long
        On Error Resume Next
        lTestExtraDimension = UBound(arg_a1D, 2) - LBound(arg_a1D, 2)   1
        On Error GoTo 0
        If lTestExtraDimension > 0 Then
            Exit Function   'argument is an array, but already has more than 1 dimension
        End If
    End If
    
    'Get maximum number of delimiters in the data
    'This allows the resulting 2d array to handle any number of resulting columns
    Dim vElement As Variant
    Dim lNumDelims As Long, lMax As Long
    For Each vElement In arg_a1D
        lNumDelims = ((Len(vElement) - Len(Replace(vElement, arg_sDelimiter, vbNullString))) / Len(arg_sDelimiter))   1
        If lNumDelims > lMax Then lMax = lNumDelims
    Next vElement
    
    'Prepare the 2D results array
    Dim a2D() As Variant:   ReDim a2D(1 To (UBound(arg_a1D) - LBound(arg_a1D)   1), 1 To lMax)
    
    'Prepare loop variables
    Dim aTemp As Variant, vTemp As Variant
    Dim lRowIndex As Long, lColIndex As Long
    
    'Loop through 1D array
    For Each vElement In arg_a1D
        lRowIndex = lRowIndex   1   'Increase 2D's row index
        lColIndex = 0               'Reset 2D's col index
        
        'Split the current 1D array element by the delimiter
        aTemp = Split(vElement, arg_sDelimiter)
        
        'Loop through the temporary array that has been created by Split
        For Each vTemp In aTemp
            lColIndex = lColIndex   1   'Advance the ColIndex
            
            'If including the delimiter in the results, and if the column index is > 1, add the delimiter to the result
            If arg_bIncludeDelim And lColIndex > 1 Then a2D(lRowIndex, lColIndex) = arg_sDelimiter
            
            'Output the result to the appropriate row and column in the 2D array
            a2D(lRowIndex, lColIndex) = a2D(lRowIndex, lColIndex) & vTemp
        Next vTemp
    Next vElement
    
    'Return 2 dimensional results array
    Transform_1D_to_2D_Array = a2D
    
End Function

Here is how you would call it:

Sub tgr()
    
    'Delcare and set worksheet and range variables
    Dim ws As Worksheet:    Set ws = ThisWorkbook.Worksheets("table1")
    Dim rData As Range:     Set rData = ws.UsedRange.Columns("A")
    
    'Call function GetUniqueValuesFromRange and populate the results into an array
    Dim aUnqVals() As Variant:  aUnqVals = GetUniqueValuesFromRange(rData)
    
    'Verify the array has results and that the data range wasn't empty
    If UBound(aUnqVals) - LBound(aUnqVals)   1 = 0 Then
        MsgBox "ERROR: No data found in " & rData.Address(External:=True)
        Exit Sub
    End If
    
    'Call function Transform_1D_to_2D_Array to convert the 1 dimensional array into a 2 dimensional array
    Dim aTransformed As Variant:    aTransformed = Transform_1D_to_2D_Array(aUnqVals)
    
    'Verify the result is actually an array
    If Not IsArray(aTransformed) Then
        MsgBox "ERROR: Attempted to transform either a non-array, or array is already multi-dimensional"
        Exit Sub
    End If
    
    'Output results
    ws.Range("D2").Resize(UBound(aTransformed, 1), UBound(aTransformed, 2)).Value = aTransformed
    
End Sub

And for those interested, this is my take on GetUniqueValuesFromRange:

'This function gets unique values from a range
'Arguments:
'  arg_rData = A range object
'   Required
'  arg_bIgnoreCase = Boolean (True/False) value on whether to ignore case for determing a unique value
'   Optional
'   Default value is True (case sensitivity will be ignored); AKA "TEST" and "test" will be treated as the same unique value
'  arg_bIgnoreBlank = Boolean (True/False) value on whether to ignore blanks in the output results
'   Optional
'   Default is True (blanks will be ignored)
Function GetUniqueValuesFromRange( _
    ByVal arg_rData As Range, _
    Optional ByVal arg_bIgnoreCase As Boolean = True, _
    Optional ByVal arg_bIgnoreBlank As Boolean = True _
) As Variant()
    
    'Convert the range of values into an array
    Dim aData() As Variant
    If arg_rData.Cells.Count = 1 Then
        ReDim aData(1 To 1, 1 To 1)
        aData(1, 1) = arg_rData.Value
    Else
        aData = arg_rData.Value
    End If
    
    'Prepare a dictionary object in order to identify unique values
    Dim hUnqVals As Object: Set hUnqVals = CreateObject("Scripting.Dictionary")
    
    'If ignoring case sensitivity, set the compare mode to vbTextCompare
    If arg_bIgnoreCase Then hUnqVals.CompareMode = vbTextCompare
    
    'Loop through the array of values
    Dim vData As Variant
    For Each vData In aData
        'Test if value is blank
        If Len(vData) = 0 Then
            'If ignoring blanks, the skip this value, otherwise include it (if not already included)
            If arg_bIgnoreBlank = False Then
                If hUnqVals.Exists(vData) = False Then hUnqVals.Add vData, vData
            End If
        Else
            'Value not blank, include it (if not already included)
            If hUnqVals.Exists(vData) = False Then hUnqVals.Add vData, vData
        End If
    Next vData
    
    'Return unique values
    GetUniqueValuesFromRange = hUnqVals.Keys
    
End Function

Image showing source data and results (with an example of one of the data points requiring a third column based on the delimiter):