Text to row VBA codes error in excel

Question

I am using these codes for text to row purpose but i am not able to convert it after certain Number of rows in Col B. whereas it is working fine for col c and d. one more thing if i am removing the on error resume next then i am getting subscript out of range error. please help me on these errors.

Expected Output for given input:

---

Code:

Sub Main()
On Error Resume Next
Columns("B:B").NumberFormat = "@"
Dim i As Long, c As Long, r As Range, v As Variant

For i = 1 To Range("B" & Rows.Count).End(xlUp).Row
    v = Split(Range("B" & i), ",")
    c = c + UBound(v) + 1
Next i

For i = 2 To c
    Set r = Range("B" & i)
    Dim arr As Variant
    arr = Split(r, ",")
    Dim j As Long
    r = arr(0)
    For j = 1 To UBound(arr)
        Rows(r.Row + j & ":" & r.Row + j).Insert shift:=xlDown
        r.Offset(j, 0) = arr(j)
        r.Offset(j, -1) = r.Offset(0, -1)
        r.Offset(j, 1) = r.Offset(0, 1)
    Next j
Next i

Columns("C:C").NumberFormat = "@"
For i = 1 To Range("C" & Rows.Count).End(xlUp).Row
    v = Split(Range("C" & i), ",")
    c = c + UBound(v) + 1
Next i
For i = 2 To c
    Set r = Range("C" & i)
    arr = Split(r, ",")
    r = arr(0)
    For j = 1 To UBound(arr)
    r.Offset(j, 0) = arr(j)
    r.Offset(j, 1) = r.Offset(0, 1)
    Next j
Next i
Columns("D:D").NumberFormat = "@"
For i = 1 To Range("D" & Rows.Count).End(xlUp).Row
    v = Split(Range("D" & i), ",")
    c = c + UBound(v) + 1
Next i
For i = 2 To c
    Set r = Range("D" & i)

    arr = Split(r, ",")
    r = arr(0)
    For j = 1 To UBound(arr)
    r.Offset(j, 0) = arr(j)
    r.Offset(j, 1) = r.Offset(0, 1)
    Next j
Next i
Columns("E:E").NumberFormat = "@"

For i = 1 To Range("E" & Rows.Count).End(xlUp).Row
    v = Split(Range("E" & i), ",")
    c = c + UBound(v) + 1
Next i
For i = 2 To c
    Set r = Range("E" & i)

    arr = Split(r, ",")
    r = arr(0)
    For j = 1 To UBound(arr)
    r.Offset(j, 0) = arr(j)
    r.Offset(j, 1) = r.Offset(0, 1)
    Next j
Next i
End Sub

Answer 1

So here is a code that works (reposted here as I guess you will close your other question):

Option Explicit

Sub SplitByRows()
Dim Col As Long, LastRow As Long, ColParts() As String
Dim i, a, k As Long
Dim StringNo As String
LastRow = Cells(Rows.Count, "B").End(xlUp).Row

For i = 2 To LastRow
    k = CountChrInString(Cells(i, 2).Value, ",")
    StringNo = Cells(i, 1).Value
        For a = 1 To k
            Cells(i, 1).Value = Cells(i, 1).Value & "," & StringNo
        Next a
Next i

For Col = 1 To 5 'Column A to Column C
    ColParts = Split(Join(Application.Transpose(Range(Cells(2, Col), Cells(LastRow, Col))), ","), ",")
    With Cells(2, Col).Resize(UBound(ColParts) + 1)
    .NumberFormat = "_(* #,##0.00_);_(* (#,##0.00);_(* ""-""??_);_(@_)"
    .Value = Application.Transpose(ColParts)
    End With
Next

End Sub


Public Function CountChrInString(Expression As String, Character As String) As Long

    Dim iResult As Long
    Dim sParts() As String

    sParts = Split(Expression, Character)

    iResult = UBound(sParts, 1)

    If (iResult = -1) Then
    iResult = 0
    End If

    CountChrInString = iResult

End Function

All I did was adding some "," to the first column as well at the beginning of your code.

For this I needed to count the amount of "," in the cell of the second column. This was done with the function from this page: How to find Number of Occurences of Slash from a strings

After that your code just did the rest ;)

Answer 2

Here is a code that works.

Before: Inv Hours Bill am Loc 1 10,12 1,2 10,24 BANG,KOL 2 1,2,3 1,2,3 1,4,9 A,B,C

After: Inv Hours Bill am Loc 1 10 1 10 BANG 1 12 2 24 KOL 2 1 1 1 A 2 2 2 4 B 2 3 3 9 C

Option Explicit

Sub Main()

Columns("B:B").NumberFormat = "@"
Dim i As Long, c As Long, r As Range, v As Variant

For i = 1 To Range("B" & Rows.Count).End(xlUp).Row
    v = Split(Range("B" & i), ",")
    c = c + UBound(v) + 1
Next i

For i = 2 To c
    Set r = Range("B" & i)
    Dim arr As Variant
    arr = Split(r, ",")
    Dim j As Long
    r = arr(0)
    For j = 1 To UBound(arr)
        Rows(r.Row + j & ":" & r.Row + j).Insert shift:=xlDown
        r.Offset(j, 0) = arr(j)
        r.Offset(j, -1) = r.Offset(0, -1)
        r.Offset(j, 1) = r.Offset(0, 1)
    Next j
Next i


Columns("C:C").NumberFormat = "@"
For i = 1 To Range("C" & Rows.Count).End(xlUp).Row
    v = Split(Range("C" & i), ",")
    'c = c + UBound(v) + 1
Next i
For i = 2 To c
    Set r = Range("C" & i)
    arr = Split(r, ",")
    r = arr(0)
    For j = 1 To UBound(arr)
    r.Offset(j, 0) = arr(j)
    r.Offset(j, 1) = r.Offset(0, 1)
    Next j
Next i
Columns("D:D").NumberFormat = "@"

For i = 1 To Range("D" & Rows.Count).End(xlUp).Row
    v = Split(Range("D" & i), ",")
    'c = c + UBound(v) + 1
Next i
For i = 2 To c
    Set r = Range("D" & i)

    arr = Split(r, ",")
    r = arr(0)
    For j = 1 To UBound(arr)
    r.Offset(j, 0) = arr(j)
    r.Offset(j, 1) = r.Offset(0, 1)
    Next j
Next i
Columns("E:E").NumberFormat = "@"

For i = 1 To Range("E" & Rows.Count).End(xlUp).Row
    v = Split(Range("E" & i), ",")
    'c = c + UBound(v) + 1
Next i
For i = 2 To c
    Set r = Range("E" & i)

    arr = Split(r, ",")
    r = arr(0)
    For j = 1 To UBound(arr)
    r.Offset(j, 0) = arr(j)
    r.Offset(j, 1) = r.Offset(0, 1)
    Next j
Next i
End Sub