CODEWITHSUNDEEP
excelvba
Brian McDougall
Brian McDougall

Reputation: 71

Text To Columns then Transpose

I need to clean up a data dump that was exported to Excel.

It is a file with groups and members in the groups from a directory. The problem is all of the members are in one cell, delimited by a semi-colon.

What I think needs to be done is to create a macro that first does text-to-columns to separate the data into columns and then somehow insert enough rows to transpose the columns into rows.

I want this:

+---+--------+---------------------+
|   |   A    |          B          |
+---+--------+---------------------+
| 1 | Group1 | Name1; Name2; Name3 |
| 2 | Group2 | Name1               |
| 3 | Group3 | Name1; Name2        |
+---+--------+---------------------+`

To look like this:

+---+--------+-------+
|   |   A    |   B   |
+---+--------+-------+
| 1 | Group1 | Name1 |
| 2 | Group1 | Name2 |
| 3 | Group1 | Name3 |
| 4 | Group2 | Name1 |
| 5 | Group3 | Name1 |
| 6 | Group3 | Name2 |
+---+--------+-------+

These "name" cells can contain from 1 to 500 names.

Edit: While my question is similar to the one that was flagged there are differences that require different code. The other question involves parsing data from the first column into new rows and copying down the subsequent columns. My problem is sort of the opposite.

Upvotes: 1

Views: 2261

Answers (2)

Brian McDougall
Brian McDougall

Reputation: 71

Here is the code that I used to do the job. Basically it cuts out the first name, pastes it in the active cell, inserts a new row and pastes the remaining names and group, offsets by one row, then loops back. I had to add a loop to remove leading spaces from the separated names.

    Sub Separate_Names()

    Dim nameStr As String 'Holds the value for the members of the group
    Dim groupStr As String 'Holds the value of the group name
    Dim delimitStr As String 'The character used to seperate names

    Dim cutAtInt As Integer 'Holds the value of where to cut name
    Dim spaceInt As Integer 'Value for first space

    delimitStr = ";" 'The character that the names are delimited by

    Range("B2").Activate 'Activate the first cell to change
    cutAtInt = InStr(nameStr, delimitStr)

    'Loop Begins
    Do Until IsEmpty(ActiveCell.Value)


    nameStr = ActiveCell
    cutAtInt = InStr(nameStr, delimitStr)

    If cutAtInt > 0 Then
        groupStr = ActiveCell.Offset(0, -1).Value
        'Loop to trim leading spaces
        spaceInt = InStr(nameStr, " ")
        Do Until spaceInt <> 1
            nameStr = Right(nameStr, Len(nameStr) - 1)
            spaceInt = InStr(nameStr, " ")
        Loop
        cutAtInt = InStr(nameStr, delimitStr)
        ActiveCell.Value = Left(nameStr, cutAtInt - 1)
        nameStr = Right(nameStr, Len(nameStr) - (cutAtInt + 1))
        ActiveCell.Offset(1, 0).EntireRow.Insert Shift:=xlDown
        ActiveCell.Offset(1, 0).Value = nameStr
        ActiveCell.Offset(1, -1).Value = groupStr
    Else
        spaceInt = InStr(nameStr, " ")
        Do Until spaceInt <> 1
            nameStr = Right(nameStr, Len(nameStr) - 1)
            spaceInt = InStr(nameStr, " ")
        Loop
        ActiveCell.Value = nameStr
    End If

    ActiveCell.Offset(1, 0).Activate

    Loop

    End Sub

Let me know if there's any improvements that I can make.

Upvotes: 1

AmBo
AmBo

Reputation: 121

Sub Spl()

Dim P1 As Range, T2(), a As Integer
Set P1 = Sheets(1).UsedRange 'Adapt to your data sheet and range
T1 = P1
a = 1

For i = 1 To UBound(T1)
    If i = 1 Then
        ReDim Preserve T2(1 To 3, 1 To a)
        T2(1, a) = T1(i, 1)
        T2(2, a) = T1(i, 2)
        T2(3, a) = T1(i, 3)
        a = a + 1
    Else
        Spl1 = Split(T1(i, 3), ";")
        For j = 0 To UBound(Spl1)
            ReDim Preserve T2(1 To 3, 1 To a)
            T2(1, a) = T1(i, 1)
            T2(2, a) = T1(i, 2)
            T2(3, a) = Trim(Spl1(j))
            a = a + 1
        Next j
    End If
Next i

Sheets(2).Range("A1").Resize(UBound(T2, 2), UBound(T2, 1)) = Application.Transpose(T2) 'Adapt to your destination

End Sub

Upvotes: 0

Related Questions