Split and write in cell in VBA-CodePudding

I get some unclean data from a text file, and in the text file, I process it as per the data in the VBA script, which gives the following output.

This is the Raw String.

1* student 1*2018-01-01*1*1234122
2* student 2*2017-01-01*1*54654654234
3* student 3*2015-01-01*4*54234654654
4* student 4*2012-01-01*5*546542345654

I wanted the output in different cells, as mentioned below in any open worksheet in excel.

Roll No	Student Name	Date of Birth	class	phone
1	student 1	2018-01-01	1	1234122
2	student 2	2017-01-01	1	54654654234
3	student 3	2015-01-01	4	54234654654
4	student 4	2012-01-01	5	546542345654

I tried various sources but couldn't get the expected output. Any help will be appreciated.

CodePudding user response：

Please, try the next way. It assumes that the whole text you show is in a single cell, not in different linens. But the above way will also deal with a single row:

Sub extractTextDelimSep()
   Dim x As String, arr, arrLine, arrFin, cols As Long, i As Long, j As Long
   x = "1* student 1*2018-01-01*1*1234122" & vbCr & _
        "2* student 2*2017-01-01*1*54654654234" & vbCr & _
        "3* student 3*2015-01-01*4*54234654654" & vbCr & _
        "4* student 4*2012-01-01*5*546542345654"
    arr = Split(x, vbCr) 'split the rows
    cols = UBound(Split(arr(0), "*"))   1 'determine the columns number per row
    ReDim arrFin(1 To UBound(arr)   1, 1 To cols) 'ReDim the final array
    
    For i = 0 To UBound(arr)
        arrLine = Split(Replace(arr(i), " ", ""), "*")
        For j = 0 To UBound(arrLine)
            arrFin(i   1, j   1) = arrLine(j)
        Next j
    Next i
    
    Range("B2").Resize(UBound(arrFin), UBound(arrFin, 2)).Value = arrFin
End Sub

Instead using x as a built string you my have the string in a cell and you can use x = ActiveCell.value.

It is easy to transform the above code in a function, too...

Edited:

You can use the next function:

Function extractTextDelimSep(x As String) As Variant
   Dim arr, arrLine, arrFin, cols As Long, i As Long, j As Long
   
    arr = Split(x, vbCr)
    cols = UBound(Split(arr(0), "*"))   1
    ReDim arrFin(1 To UBound(arr)   1, 1 To cols)
    
    For i = 0 To UBound(arr)
        arrLine = Split(Replace(arr(i), " ", ""), "*")
        For j = 0 To UBound(arrLine)
            arrFin(i   1, j   1) = arrLine(j)
        Next j
    Next i
    extractTextDelimSep = arrFin
End Function

If everything is in the same cell (in column A:A), you should call it in the next way:

Sub TestextractTextDelimSep()
   Dim x As String, arr

    x = ActiveCell.Value
    arr = extractTextDelimSep(x)
    'drop the array content at once:
    Range("B" & ActiveCell.row).Resize(UBound(arr), UBound(arr, 2)).Value = arr
End Sub

If the string is distributed one line of a (different) cell, you can use:

Sub TestextractTextDelimSepRange()
   Dim lastR As Long, arr, i As Long

     lastR = Range("A" & rows.count).End(xlUp).row
     For i = 1 To lastR
          arr = extractTextDelimSep(Range("A" & i).Value)
          Range("B" & i).Resize(1, UBound(arr, 2)).Value = arr
     Next i
End Sub

For this last case, in Excel 365 it can be used as UDF function, being called from the cell as formula:

  =extractTextDelimSep(A1) 'in A1 should be the line to be split