Split cell with multiple lines into rows and change grouping with vba

Question

i would like to split the cells into TextA, TextB and TextC after "." and sort by the Text genre.

I also tried this:

Sub split_By_Text()

Set sh1 = ThisWorkbook.Sheets(1)
Set sh2 = ThisWorkbook.Sheets(2)


lrow1 = sh1.Range("A65356").End(xlUp).Row


For j = 2 To lrow1

splitVals = Split(sh1.Cells(j, 2), ".")

totalVals = UBound(splitVals)

For i = LBound(splitVals) To UBound(splitVals)
    lrow2 = sh2.Range("B65356").End(xlUp).Row
    lrow3 = sh2.Range("A65356").End(xlUp).Row
    sh2.Cells(lrow3 + 1, 1) = sh1.Cells(j, 1)
    'Debug.Print sh1.Cells(j, 1)
    sh2.Cells(lrow2 + 1, 2) = splitVals(i)
    'Debug.Print splitVals(i)
Next i

Next j

sh2.Activate




sh2.Range("A1") = "Drink ID"
sh2.Range("B1") = "Recipe_data"
sh2.Range("C1") = "Volume"



End Sub

But when i have only one sentence excel also add a line.

THX

Input:

Output:

Would you please concisely state your question? Any info around the errors you are receiving when executing your code would also be appreciated, relative to their location in your code. — Cyril, Nov 05 '19 at 18:34
i dont get any errors but the output of the code is something like this: ID; TextC 1; Text3 1; Text9 2; Text10 2; Text11 — Pumuckl19901, Nov 05 '19 at 18:43
Please add all information into your post. It is ne'ry unreadable as a comment. What is the exact issue with your output? — Cyril, Nov 05 '19 at 18:49
If you `Split` by a dot, your array will return one more item (`""`) than you expect because all your strings end with a dot. With other words: `arr = Split("Hello.World.",".")` will return `Ubound(arr)` = 2! > `{0,1,2}`. Without reading the rest of your code you probably want to use: `For i = LBound(splitVals) To UBound(splitVals)-1` — JvdV, Nov 05 '19 at 18:59
If you have Excel 2010 or later, you can do this fairly easily using `Power Query` — Ron Rosenfeld, Nov 05 '19 at 19:50

score 0 · Answer 1 · answered Nov 05 '19 at 21:33

Rearrange data to be split due to genre

Demonstrate an approach via array assignment and using the advanced restructuring features of the Application.Index() function:

Sub ReArrange()
Const GENRE& = 1, ID& = 2, TXT& = 5, TXTA& = 6, TXTB& = 7, TXTC& = 8                     ' columns in variant array v2
With Sheet1                                   ' source sheet's CodeName (!)
  ' [0] define data range
    Dim v, rng As Range, lastRow&
    lastRow = .Range("A" & .Rows.Count).End(xlUp).Row
    Set rng = .Range("A1:F" & lastRow)
  ' [1] get data
    v = rng
  ' [2] rearrange array rows & columns (inserting 2 new columns)
    v = Application.Index(v, _
         Application.Transpose(getRows(v)), _
         Array(0, 1, 2, 3, 0, 4, 5, 6))
    v(1, GENRE) = "Genre": v(1, TXT) = "Text"    ' renew headers
  ' [3] Fill in genre & tokens
    Dim i&, ii&, cnt&                             ' item counters
    Dim a&, b&, c&                                ' split item boundaries

    For i = 2 To UBound(v)                        ' loop through v2
        If v(i, ID) <> v(i - 1, ID) Then
            cnt = 0: ii = 0
            a = UBound(Split(v(i, TXTA), "."))    ' items TextA
            b = UBound(Split(v(i, TXTB), "."))    ' items TextB
            c = UBound(Split(v(i, TXTC), "."))    ' items TextC
        End If
        cnt = cnt + 1: ii = ii + 1                ' increment id and genre counters
        Select Case cnt
            Case Is <= a: v(i, GENRE) = "A"
                v(i, GENRE) = "A": v(i, TXT) = Split(v(i, TXTA), ".")(ii - 1): If ii = a Then ii = 0
            Case Is <= a + b
                v(i, GENRE) = "B": v(i, TXT) = Split(v(i, TXTB), ".")(ii - 1): If ii = b Then ii = 0
            Case Is <= a + b + c
                v(i, GENRE) = "C":  v(i, TXT) = Split(v(i, TXTC), ".")(ii - 1): If ii = c Then ii = 0
        End Select

    Next i
End With

  ' [4] write results back whereever you want (reducing array by 3 temporary columns)
    Sheet2.Range("A1").Resize(UBound(v), UBound(v, 2) - 3) = v

End Sub

Helper function getRows()

Function getRows(arr) As Variant()
' Purpose: return an array of n-times repeated row numbers (based on number of splits)
Dim i&, ii&, j&, cnt&
Dim tmp(), tokens
ReDim tmp(0 To UBound(arr) * 10)
tmp(cnt) = 1: cnt = cnt + 1        ' one title row equals row no 1; increment new rows counter
For i = 2 To UBound(arr)
    For j = 4 To 6                  ' D:F
        tokens = Split(arr(i, j), ".")  ' upper boundary minus one because of right side point
        For ii = LBound(tokens) To UBound(tokens) - 1
            tmp(cnt) = i            ' input row number as often as necessary
            cnt = cnt + 1           ' increment counter
        Next ii
    Next
Next i
ReDim Preserve tmp(0 To cnt - 1)    ' resize array to actual item size
getRows = tmp                       ' return function result array
'Debug.Print Join(tmp, ",")         ' Array(1,2,2,2,3,3,3,3,3,3,3,3,4,4,4,4,4,4,5,5,5,5,5,5,6,6,6,6,6,6)
End Function

@Pumuckl19901 - Allow me a remark as this is your 2nd question so far: it's good practice on SO to accept answers that work for you or you find useful (by ticking the hollow green checkmark just underneath the voting buttons, near the top of this answer), so that others can benefit going forward :-) — T.M., Nov 16 '19 at 16:53

Split cell with multiple lines into rows and change grouping with vba

1 Answers1