Excel VBA - best way to store and rewrite nested data

Question

I am trying to build a vba tool that breaks out nested data from a particular cell and repeats the other fields in each row for each nest value. For example, the following:

Bldg 3000 | Floor 2 | 201, 20, 203
Bldg 7010 | Floor 1 | 110, 151

Should become:

Bldg 3000 | Floor 2 | 201
Bldg 3000 | Floor 2 | 202
Bldg 3000 | Floor 2 | 203
Bldg 7010 | Floor 1 | 110
Bldg 7010 | Floor 1 | 151

I started making the below program to import all the spreadsheet data into an array; however, I wasn't sure how to handle the nested values so this is just copying the spreadsheet as is so far:

Sub import()
Dim ws As Worksheet
Dim rng As Range
Dim listing() As Variant
Set ws = ThisWorkbook.Sheets("Export Worksheet")
Set rng = ws.Cells.CurrentRegion
spreadsheet = rng
Set ws2 = ThisWorkbook.Sheets.Add
ws2.Name = "test"
For i = 1 To UBound(spreadsheet, 1)
    For j = 1 To UBound(spreadsheet, 2)
        Debug.Print spreadsheet(i, j)
        ws2.Cells(i, j) = spreadsheet(i, j)
        'Need to somehow get nested data in the appropriate cells and count/store the 
        'unique words so that when I write to sheet, I can have another nested loop that repeats
        'all row data except the target column which loops through unique words and breaks them 'out 1 x 1
    Next j
Next i

End Sub

So I tried to incorprate a function that get the unique words. It worked before I made the array that stores the unique words as two dimensional, so that I can store the row number as well as each uniqe word (in our example above, I'd have 3 entries with a row number of 1, and their corresponding values would be 201, 202, and 203. Then I'd have 2 entries with a row number of 2, with the unique values being 110 and 151).

My attempt is below and I receive an error when I try to redim preserve the multidimensional array. I'm sure this isn't the best approach and any guidance would be appreciated.

Dim words() As Variant
Dim strng As String
Dim myRng As Range, r As Range
ReDim words(0, 2)

Function getWords_new(st As String, address As String, row As Long)
'Dim words() As Variant
'ReDim words(0, 2)
'ReDim words(0)
word_length = Len(st)
Start = 1
If word_length = 0 Then
    words(UBound(words, 1), 1) = row
    words(UBound(words, 1), 2) = "NULL"
Else:
    For i = 1 To word_length
        If Mid(st, i, 1) = "," Then
            finish = i
            Gap = finish - Start
            If Gap > 0 Then
                word = Mid(st, Start, Gap)
                lim = UBound(words, 1)
                If lim > 0 Then
                    'ReDim Preserve words(1 To lim + 1, 1 To UBound(words, 2))
                    'from: https://stackoverflow.com/questions/25095182/redim-preserve-with-multidimensional-array-in-excel-vba
                    y = UBound(words, 2)
                    ReDim Preserve words(lim + 1, y)
                    words(lim, 2) = word
                Else:
                    ReDim Preserve words(lim + 1, UBound(words, 2))
                    words(0, 2) = word
                End If
                Start = finish + 1
            End If
            ElseIf i = word_length Then
            word = Mid(st, Start, word_length)
            lim = UBound(words, 1)
            If lim > 0 Then
                ReDim Preserve words(lim + 1, UBound(words, 2))
                words(lim, 2) = word
            Else: words(0, 2) = word
            End If
            Start = finish + 1
        End If
    Next i
End If
word_count = UBound(words, 1)

'If word_count > 0 Then
'    'Debug.Print address & " - Word count is: " & word_count
Debug.Print "Words are: "
    For i = 0 To UBound(words, 1)
        For j = 0 To UBound(words, 2)
'        Set ws = ThisWorkbook.Sheets("Stats")
'        lr = ws.Cells(Rows.Count, 1).End(xlUp).Row
'        ws.Cells(lr + 1, 1) = address
'        ws.Cells(lr + 1, 2) = words(i)
'        ws.Cells(lr + 1, 3) = word_count
            Debug.Print words(i, j)
        Next j
'   Next i
'End If
End Function

You can only ReDim the last dimension of an array so if you really need to do it for both dimensions, you should use 2 seperated arrays. — Plagon
– Plagon, Commented Jul 10, 2017 at 12:42
Have a Split() function. It can convert a comma seperated string, into an array. Combine that with some logic, and you should be able to achieve your goal... — Jakob Busk Sørensen
– Jakob Busk Sørensen, Commented Jul 10, 2017 at 13:03
@UGP, thanks for the advice. Sorry, but I don't fully understand. Since I need to associate the orginal row ID with the words being stored, how would I associate the two separate arrays? — flwr_pwr
– flwr_pwr, Commented Jul 10, 2017 at 13:04
@Noceo, Thank you. I should be able to use split to get the words much more efficiently. I still have to figure out how to handle the storing of nested data — flwr_pwr
– flwr_pwr, Commented Jul 10, 2017 at 13:05

Gary's Student · Accepted Answer · 2017-07-10 13:34:16Z

1

If you start with this in Sheet1:

and run this short macro:

Sub reprg()
    Dim N As Long, K As Long, s1 As Worksheet, s2 As Worksheet
    Dim i As Long, j As Long
    Set s1 = Sheets("Sheet1")
    Set s2 = Sheets("Sheet2")

    K = 1
    N = s1.Cells(Rows.Count, "A").End(xlUp).Row

    For i = 1 To N
        v1 = s1.Cells(i, 1)
        v2 = s1.Cells(i, 2)
        ary = Split(s1.Cells(i, 3), ", ")
        For Each a In ary
            s2.Cells(K, 1) = v1
            s2.Cells(K, 2) = v2
            s2.Cells(K, 3) = a
            K = K + 1
        Next a
    Next i
End Sub

you will get this in Sheet2:

Just make the necessary changes required to use your sheet names and column assignments.

edited Jul 10, 2017 at 13:34

answered Jul 10, 2017 at 13:22

Gary's Student

96.9k10 gold badges66 silver badges104 bronze badges

Sign up to request clarification or add additional context in comments.

Comments

Glenn G · Accepted Answer · 2017-07-10 13:16:20Z

This may not be the best method of doing it but this is what I'd do

Option Explicit

Dim xlCell As Range
Dim xlOutput As Range
Dim S1 As String


Sub SplitData()
    Set xlOutput = ActiveCell.Offset(0, 5)
    For Each xlCell In Selection
        S1 = xlCell.Offset(0, 2).Value
        Do Until InStr(1, S1, ",", vbTextCompare) < 1
            With xlOutput
                .Value = xlCell.Value
                .Offset(0, 1).Value = xlCell.Offset(0, 1).Value
                .Offset(0, 2).Value = Mid(S1, 1, InStr(1, S1, ",", vbTextCompare) - 1)
            End With
            S1 = Trim(Mid(S1, InStr(1, S1, ",", vbTextCompare) + 1, Len(S1)))
            Set xlOutput = xlOutput.Offset(1, 0)
        Loop
        With xlOutput
            .Value = xlCell.Value
            .Offset(0, 1).Value = xlCell.Offset(0, 1).Value
            .Offset(0, 2).Value = S1
        End With
        Set xlOutput = xlOutput.Offset(1, 0)
    Next xlCell
End Sub

Then just select the cells in the first column of data and run the code. If you wanted to automatically select them, that can be done as well with just a small tweak to the code

Jakob Busk Sørensen · Accepted Answer · 2017-07-10 13:27:05Z

0

Try this (slightly oversimplified) code:

Sub SplitToSeperateRows()
    r = 1
    For i = 1 To 2
        stringToSplit = Sheets("Sheet1").Cells(i, "C")
        stringAsArray = Split(stringToSplit, ",")

        For j = 0 To UBound(stringAsArray)
            With Sheets("Sheet2")
                .Cells(r, "A") = Sheets("Sheet1").Cells(i, "A")
                .Cells(r, "B") = Sheets("Sheet1").Cells(i, "B")
                .Cells(r, "C") = stringAsArray(j)
                r = r + 1
            End With
        Next j

    Next i
End Sub

answered Jul 10, 2017 at 13:27

Jakob Busk Sørensen

6,20110 gold badges59 silver badges116 bronze badges

Collectives™ on Stack Overflow

Excel VBA - best way to store and rewrite nested data

3 Answers 3

Comments

Comments

Comments

Your Answer

Linked

Hot Network Questions

Collectives™ on Stack Overflow

3 Answers 3

Comments

Comments

Comments

Your Answer

Sign up or log in

Post as a guest

Linked

Related