split multiple values from a single cell with each split cell in a duplicate row

Question

Hi i have a big spreadsheet, In one cell on each row i have multiple values seperate by a ;

i need to paste each one of theses values into its own row with the same row information from where it came from. I have about 5235 different rows this needs to happen on. There are multiple diff values in each row.

example of what i have

enity ID | Name   | type | time | ref no | 

26484 | name1 | 21 |  2356 | 9502;9503;10615;9504; |                   

12778| name11 | 34 |0946  |10600;9506;9526; |

abd12| name22 | 20 | 1726 |10258;10259;10293;10308;10300; |                   

fde34  | name26 | 45 | 1246|9066;9065;9069;9070;9074;9073;9077;10816;9064;9085;9087;1083|

qw223| name30 | 28 |0328 |9069;9070;9074;|               

789op| name41 | 50 |1149 |10258;10259; |                   

11hty9| name5 | 14 | 0513 | 9073;9077;10816;9064;9085; |

so i need the "ref no" row duplicated as many times as there are diff values, with each row having a diff value from the orginial row

PLEASE HELP

Answer 1

Try this macro:

Sub SplitValues()

    Const c = 5 ' column with multiple values

    Dim r As Long

    Dim m As Long

    Dim arrParts

    Dim i As Long

    Application.ScreenUpdating = False

    m = Cells(Rows.Count, c).End(xlUp).Row

    For r = m To 2 Step -1

        arrParts = Split(Cells(r, c), ";")

        If UBound(arrParts) > 0 Then

            For i = UBound(arrParts) To 1 Step -1

                If arrParts(i) <> "" Then

                    With Cells(r, c).EntireRow

                        .Copy

                        .Insert

                    End With

                    Cells(r + 1, c) = arrParts(i)

                End If

            Next i

            Cells(r, c) = arrParts(0)

        End If

    Next r

    Application.CutCopyMode = False

    Application.ScreenUpdating = True

End Sub