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

Question

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

Answer 1

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

Answer 2

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

Answer 3

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):

Answer 4

Arrays: 1D to 2D with Split
Sub OneDToTwoD()
' Reference the Source range.
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Worksheets("Table1")
Dim srg As Range: Set srg = ws.UsedRange.Columns("A")
' Using the 'getUniqueValuesFromRange' function,
' return the unique values of the Source range in a 1D array.
Dim Arr As Variant: Arr = getUniqueValuesFromRange(srg)
' Split the strings in the 1D array and return the substrings
' in a 2D one-based two-column array.
Dim rCount As Long: rCount = UBound(Arr) - LBound(Arr) + 1
Dim Data() As Variant: ReDim Data(1 To rCount, 1 To 2)
Dim i As Long, r As Long, strPos As Long, strLen As Long
For i = LBound(Arr) To UBound(Arr)
strPos = InStrRev(Arr(i), "/")
strLen = Len(Arr(i))
r = r + 1
Data(r, 1) = Mid(Arr(i), 1, strPos - 1) ' exclude delimiter
Data(r, 2) = Mid(Arr(i), strPos, strLen - strPos + 1) ' include delim. ?
'Data(r, 2) = Mid(Arr(i), strPos + 1, strLen - strPos) ' exclude delim.
Next i
' Reference the Destination range.
Dim drg As Range: Set drg = ws.Range("D2").Resize(rCount, 2)
' Write the values from the 2D array to the Destination range.
drg.Value = Data
End Sub
If your function doesn't exclude the first row you might want to reference the source range in the following way:
Dim srg As Range
With ws.UsedRange.Columns("A")
Set srg = .Resize(.Rows.Count - 1).Offset(1)
End With