Creating a automated task to copy the data into new row for each excel row

Question

I have around 41188 rows which need to be automatically adjusted, so that the column E, which will have different values divided by '|' need to be added in a new row each containing just one of the value. Data from A to D and F to G has to be copied in the new rows. Below is the sample of how the data is saved.
Before

Here is how it should be made

After

This is just a sample of the data. In the real document there are more than 41188 rows which need to be adjusted in the same way, and the E column may have different values that need to get copied in the new rows, so the row creation should be dynamically adjusted by the values divided by the operator | .

Answer 1

If you follow this link you will see it is quite easy to split a multi value field. If you have data like that

Goto Data/Get Data/From File/From Workbook and select the workbook with your data

In the editor select the multi value column and goto Transform

Select Split Column/By Delimiter

Fill in the fields like in the picture. Also open the Advanced Options and change to rows

That is the result in the editor

Goto Home/Close & Load

And you will get a new sheet with the data split by the multi value field

Answer 2

As performance is emphasized correctly by @skin, I tried the code with 41188 rows and with number of split of column E at 6. it takes around 1-2 minutes on my old laptop. In my approach, I tried the data processing in arrays and copied it to a new sheet (may modify to your choice) in one shot to keep accessing excel cells minimum. The array was transposed by the code as transposing array using WorksheetFunction may have some limitation. As I personally used to avoid keeping calculation, Screen Updating, event disabled, I have not used to off the same in the trial. it may be used for further optimization of the code.

Code:

Sub test()
tm = Timer
Dim SrcArr As Variant, TrgArr As Variant, LastRow As Long
Dim EcolVal As Variant, itm As Long, NewRw As Long
Dim Ws As Worksheet
Dim i As Long, n As Long

ReDim TrgArr(1 To 7, 0)
LastRow = ThisWorkbook.Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
SrcArr = ThisWorkbook.Sheets("Sheet1").Range("A1:G" & LastRow).Value
NewRw = 0
    For rw = LBound(SrcArr, 1) To UBound(SrcArr, 1)
    EcolVal = Split(SrcArr(rw, 5), "|")

        If UBound(EcolVal) <= 0 Then
        NewRw = NewRw + 1
        ReDim Preserve TrgArr(1 To 7, NewRw)
            For i = 1 To 7
            TrgArr(i, NewRw) = SrcArr(rw, i)
            Next
        Else
            For itm = LBound(EcolVal) To UBound(EcolVal)
            NewRw = NewRw + 1
            ReDim Preserve TrgArr(1 To 7, NewRw)
                For i = 1 To 7
                    If i = 5 Then
                    TrgArr(i, NewRw) = EcolVal(itm)
                    Else
                    TrgArr(i, NewRw) = SrcArr(rw, i)
                    End If
                Next
            Next
        End If
    Next


Dim TrgArr2 As Variant
    ReDim TrgArr2(1 To UBound(TrgArr, 2), 1 To UBound(TrgArr, 1))
    For i = 1 To UBound(TrgArr, 2)
        For n = 1 To UBound(TrgArr, 1)
            TrgArr2(i, n) = TrgArr(n, i)
        Next
    Next

 Set Ws = ThisWorkbook.Sheets.Add(After:=Sheets(Sheets.Count))
 Ws.Range("A1").Resize(UBound(TrgArr2, 1), UBound(TrgArr2, 2)).Value = TrgArr2
Debug.Print Timer - tm
End Sub

Answer 3

See if this code does what you want ...

Public Sub TransformData()
    On Error GoTo CleanUp

    Dim objSrcSheet As Worksheet, objDestSheet As Worksheet, lngEndRow As Long
    Dim lngRow As Long, rngToCopy As Range, strColToDelimit As String
    Dim strValueToDelimit As String, lngWriteRow As Long, arrValues, i As Long

    ' Change the below lines to suit your own workbook.
    Set objSrcSheet = Worksheets("Source")
    Set objDestSheet = Worksheets("Transformed")
    strColToDelimit = "E"

    objDestSheet.Cells.Clear

    lngEndRow = objSrcSheet.Cells.SpecialCells(xlCellTypeLastCell).Row

    lngWriteRow = 1

    Application.ScreenUpdating = False
    Application.EnableEvents = False

    For lngRow = 1 To lngEndRow
        Application.StatusBar = "Processing Row " & lngRow & " of " & lngEndRow & " ..."

        If lngRow Mod 500 = 0 Then DoEvents

        Set rngToCopy = objSrcSheet.Rows(lngRow)
        strValueToDelimit = objSrcSheet.Cells(lngRow, strColToDelimit)

        arrValues = Split(strValueToDelimit, "|")

        rngToCopy.Copy objDestSheet.Range("A" & lngWriteRow & ":A" & lngWriteRow + UBound(arrValues))

        For i = 0 To UBound(arrValues)
            objDestSheet.Cells(lngWriteRow, strColToDelimit) = arrValues(i)
            lngWriteRow = lngWriteRow + 1
        Next
    Next

    objDestSheet.Columns.AutoFit
    objDestSheet.Activate

CleanUp:
    Application.ScreenUpdating = True
    Application.EnableEvents = True

    Application.StatusBar = ""
End Sub

... the biggest test here will be performance and although this should work, you may want to hang out for a better performing solution.

You need to add the code into a new module within the VBA editor and change the values in the top section of the code that points to the source and destination sheet names. The way it's configured, you'll need to create a sheet called Transformed and the name of the sheet with the source data is set to Source, you can change that to be the name of the sheet you have in your workbook.

It's looking at column E for your delimited value.

Simply run the macro from the developer menu as per any other macro you've run before.

When it's processing, you'll see it updating in the status bar for how many rows it's done and how many it has determined it will need to do.

Up to you! Worth a try anyway.