VBA - Conditionally populate array from existing array-CodePudding

I'm creating an array from a text file and want to create a "subarray" from the main one.

The main array has the form

And I want to extract the A and B.

I create the "sub array" by splitting the strings from each row

For n = LBound(MainArray) To UBound(MainArray)
    If Split(MainArray(n), " ")(0) = "Data" Then
        ReDim SubArray(X)
        SubArray(X) = Split(MainArray(n), " ")(1)
        X = X   1
    End If
Next n

but doing this just returns the array (written as a vector now) (" ", B).

Why does A get overwritten by an empty space after the for loop finds the B?

Thanks and Happy Easter!

Note the example above is just a minimalist version of the real array.

CodePudding user response：

This answer is predicated on Main array being a single dimension array.

The problem you are having is that you are nott creating new sub arrays each time tou get a new 'Data xxx" and consequently just keep overwriting the previous subarray.

You will be better served in you endeavour by using a dictionary of dictionaries.

To use dictionaries you either have to add a reference to the Microsoft Scripting Runtime or use 'CreateObject("Scripting.Dicitonary"). The first option is preferred when developing code or when you are a newbie because you get intellisense. You don't get intellisense when you use late bound objects (created by CreateObject).

Scripting.Dictionaries should be preferred over collections with keys because Dictionaries allow you to retreive the Keys or Items as arrays in their own right.

Here is your code modified to use scripting Dictionaries

Dim myD As Scripting.Dictionary
Set myD = New Scripting.Dictionary

Dim mySubDName As String
mySubDName = "Unknown"

Dim myItem As Variant

For Each myItem In MainArray

    If InStr(myItem, "Data") > 0 Then
    
        mySubDName = Trim(myItem)
        If Not myD.exists(SubDName) Then
            ' Create a new sub dictionary with key 'Data XXXX'
            myD.Add mySubDName, New Scripting.Dictionary
            
        End If
        
    Else
    
        Dim myArray As Variant
        myArray = Split(Trim(myItem), " ")
        myD.Item(mySubDName).Add myArray(0), myArray(1)

    End If
    
Next

Dictionary myD will have Keys of "Data A", Data B" etc.

You retrieve a sub dictionary using

'Where XXXX is A,B,C etc
set mySubD = myD.Item("Data XXXX")

The sub dictionary has the structure (using 00000007 700 as an example) of Key=00000007 and Item = 700

If you enumerate a Dictionary using for each it returns the Key as the control variable.

You can get an array of the Keys using the .Keys method you can Get an array of the Items using the .Items Method

E.g. myD.Keys gives the array ("Data A", "Data B", "Data C", ....."Data XXX"

myD.Item("Data B").Items will give the array ("0000005", "0000006",.....,"00000010, etc"

Please do take the ttime to read up on Scripting.Dictionaries as part of understanding the above.

Good luck with your coding.

CodePudding user response：

Since you do not answer the clarification questions, please try the next code, which processes a 2D array, resulting two 2D arrays, corresponding to 'Data A' and 'Data B':

Sub Split2DArray()
 Dim MainArray, arrA, arrB, n As Long, iA As Long, iB As Long, boolFirst As Boolean
 
 'for exemplification place the picture content in A:A column, then place it in a (2D) array:
 MainArray = Range("A1:A13").value
 
 ReDim arrA(1 To 1, 1 To UBound(MainArray)): iA = 1
 ReDim arrB(1 To 1, 1 To UBound(MainArray)): iB = 1
 For n = LBound(MainArray) To UBound(MainArray)
    If MainArray(n, 1) <> "" Then
        If Split(MainArray(n, 1), " ")(0) = "Data" Then
            If Not boolFirst Then
                boolFirst = True
                arrA(1, iA) = MainArray(n, 1): iA = iA   1
           Else
                boolFirst = False
                arrB(1, iB) = MainArray(n, 1): iB = iB   1
           End If
        ElseIf boolFirst Then
            arrA(1, iA) = MainArray(n, 1): iA = iA   1
        Else
            arrB(1, iB) = MainArray(n, 1): iB = iB   1
        End If
    End If
Next n
If iA > 1 Then ReDim Preserve arrA(1 To 1, 1 To iA - 1) 'only the second dimension can be preserved
If iB > 1 Then ReDim Preserve arrB(1 To 1, 1 To iB - 1)

Range("C1").Resize(UBound(arrA, 2), 1).value = Application.Transpose(arrA)
Range("D1").Resize(UBound(arrB, 2), 1).value = Application.Transpose(arrB)
End Sub

The code can be easily adapted to process 1D arrays. If this is the case I can show you how to proceed. If many such 'Data x' slices exist, you should use a Dictionary keeping each array.

The same processing way for 1D arrays. Using the same visual elocvent way of testing:

Sub Split1DArray()
 Dim MainArray, arrA, arrB, n As Long, iA As Long, iB As Long, boolFirst As Boolean
 
 'for exemplification place the picture content in A:A column, then place it in a (2D) array:
 MainArray = Application.Transpose(Range("A1:A13").value) 'obtaining a 1D array from the same reange...
 
 ReDim arrA(1 To UBound(MainArray)): iA = 1
 ReDim arrB(1 To UBound(MainArray)): iB = 1
 For n = LBound(MainArray) To UBound(MainArray)
    If MainArray(n) <> "" Then
        If Split(MainArray(n), " ")(0) = "Data" Then
            If Not boolFirst Then
                boolFirst = True
                arrA(iA) = MainArray(n): iA = iA   1
           Else
                boolFirst = False
                arrB(iB) = MainArray(n): iB = iB   1
           End If
        ElseIf boolFirst Then
            arrA(iA) = MainArray(n): iA = iA   1
        Else
            arrB(iB) = MainArray(n): iB = iB   1
        End If
    End If
Next n
If iA > 1 Then ReDim Preserve arrA(1 To iA - 1) 'only the second dimension can be preserved
If iB > 1 Then ReDim Preserve arrB(1 To iB - 1)

Range("C1").Resize(UBound(arrA), 1).value = Application.Transpose(arrA)
Range("D1").Resize(UBound(arrB), 1).value = Application.Transpose(arrB)
End Sub

And a version using a dictionary, processing as many as `Data x' slices exist:

Sub Split1DArrayDict()
 Dim MainArray, n As Long, x As Long, arrIt, dict As Object
 
 'for exemplification place the picture content in A:A column, then place it in a (2D) array:
 MainArray = Application.Transpose(Range("A1:A18").value) 'obtaining a 1D array from the same range...
 
 Set dict = CreateObject("Scripting.Dictionary")
 For n = LBound(MainArray) To UBound(MainArray)
    If MainArray(n) <> "" Then
        If Split(MainArray(n), " ")(0) = "Data" Then
            x = x   1
            dict.Add x, Array(MainArray(n))
            arrIt = dict(x)
        Else
            ReDim Preserve arrIt(UBound(arrIt)   1)
            arrIt(UBound(arrIt)) = MainArray(n)
            dict(x) = arrIt
        End If
    End If
Next n

For n = 0 To dict.count - 1
    cells(1, 3   n).Resize(UBound(dict.items()(n))   1, 1).value = Application.Transpose(dict.items()(n))
Next n
End Sub