CODEWITHSUNDEEP
arraysvbaexcel
Nikky
Nikky

Reputation: 51

Excel-VBA splitting a string and storing the result into separate arrays

I have many strings in the format Topic/Subtopic . I need to separate both of them and store the results of topic and subtopic into different arrays.

My code is:

Dim strText() As String
Dim seperate As Variant

i = QB_StartCell '4

ReDim strText(1 To 25)

'collecting all the types in an array
Do While Worksheets("QB").Cells(i, QB_Thema).Value <> ""  'QB_Thema is a column number
    strText(i) = Worksheets("QB").Cells(i, QB_Thema).Value
    MsgBox strText(i)
    i = i + 1
Loop

noThema = i - QB_StartCell

'splitting all the types into 2 parts
Do
    
seperate = Split(strText(p), "/")

Loop Until p > noThema

Now I want both the splitted parts in separate Arrays as I want to access them later. Any help?

Upvotes: 1

Views: 1362

Answers (2)

user3598756
user3598756

Reputation: 29421

There's no need to iterate twice, first through cells and then through array.

You can make it in one iteration like this:

Option Explicit

Sub main()
Dim i As Long, lastRow As Long, nonBlankCellsNumber As Long
Dim QB_Thema As Long, QB_StartCell As Long
Dim cell As Range
Dim topicArr() As String, subTopicArr() As String

QB_Thema = 3 'added this for my test
QB_StartCell = 4

lastRow = GetLastRow(Worksheets("QB"), QB_Thema, "F", QB_StartCell) '<== I assumed as per your code that you stop at the first occurrence of a blank cell. should you want to process all non blank data to the last non blank cell, then use "L" as the 3rd argument of this call
If lastRow = -1 Then Exit Sub

With Worksheets("QB")
    With .Range(.Cells(QB_StartCell, QB_Thema), .Cells(lastRow, QB_Thema))
        nonBlankCellsNumber = WorksheetFunction.CountA(.Cells)
        ReDim topicArr(1 To nonBlankCellsNumber)
        ReDim subTopicArr(1 To nonBlankCellsNumber)
        i = 0
        For Each cell In .Cells.SpecialCells(xlCellTypeConstants, xlTextValues)
            i = i + 1
            topicArr(i) = Split(cell.value, "/")(0)
            subTopicArr(i) = Split(cell.value, "/")(1)
        Next cell
    End With
End With

End Sub


Function GetLastRow(sht As Worksheet, columnIndex As Long, FirstOrLastBlank As String, Optional firstRow As Variant) As Long
If IsMissing(firstRow) Then firstRow = 1
With sht
    If FirstOrLastBlank = "F" Then
        With .Cells(firstRow, columnIndex)
            If .value = "" Then
                GetLastRow = .End(xlDown).End(xlDown).row
            Else
                GetLastRow = .End(xlDown).row
            End If
        End With
        If GetLastRow = .Rows.count And .Cells(GetLastRow, columnIndex) = "" Then GetLastRow = firstRow
    ElseIf FirstOrLastBlank = "F" Then
        GetLastRow = .Cells(.Rows.count, columnIndex).End(xlUp).row
        If GetLastRow < firstRow Then GetLastRow = firstRow
    Else
        MsgBox "invalid 'FirstOrLastBlank' parameter"
        GetLastRow = -1
    End If
End With
End Function

As you see I also posted Function GetLastRow() to get the last row index of data to scan.

As per your code I got you want to start at row 4 and stop at the first blank cell (excluded), and so I tuned the arguments (namely the 3rd one: "F") in the call to GetLastRow accordingly.

Instead, should you want to scan all non-blank cells in the given column, then you may call the same GetLastRow function passing "L" as 3rd parameter.

Upvotes: 0

Thomas G
Thomas G

Reputation: 10226

2 solutions : one 2D array or two 1D array

Dim arr_Multi(noThema, 2) As String
Dim arr_Topic(noThema) As String
Dim arr_SubTopic(noThema) As String

Do
    seperate = Split(strText(p), "/")

    ' Choose either storage in one 2D array
        arr_Multi(p, 0) = seperate(0)
        arr_Multi(p, 1) = seperate(1)

    ' or storage in two 1D arrays
        arr_Topic(p) = seperate(0)
        arr_SubTopic(p) = seperate(1)

    p = p + 1 ' and don't forget to increment your counter in the loop

Loop Until p > noThema

If you need your array(s) outside the sub, then you should declare them like this on top of your module:

Dim arr_Multi(1, 2) As String
Dim arr_Topic(1) As String
Dim arr_SubTopic(1) As String

And in your loop you do a redim preserve of your array(s) before incrementing p:

' Either
redim preserve arr_Multi(p, 2)

'or 
redim preserve arr_Topic(p)
redim preserve arr_SubTopic(p)

Upvotes: 1

Related Questions