Split multiple Delimiter field with Header into Multiple Columns and Rows

Hi;

I have a multiple columns containing rows of concatenated columns with header delimited seperate by Colon and Field by Tilde.

Some of the Columns does not have any data due to Employee departure from the company.

RowID	LocationID	Employee 1	Employee 2	Employee 3
1	123456	First Name :John~Last Name :Smith~DOB :01-Jan-1990~Gender :Male~Salary Range :15-21	First Name :Robert~Last Name :Great~DOB :25-Jun-1967~Gender :Male~Salary Range :75-90	First Name :Adele~Last Name :Rose~DOB :18-Sep-1987~Gender :Male~Salary Range :25-30
2	123457	First Name :Angelica~Last Name :Johnson~DOB :11-Feb-1978~Gender :Female~Salary Range :40-50		First Name :Oliver~Last Name :Anderson~DOB :06-May-1970~Gender :Male~Salary Range :40-50

What i need is a VBA Macro that will Split the records into columns with Headers and rows.

RowID	LocationID	EmployeeID	First Name	Last Name	DOB	Gender	Salary Range
1	123456	123456-001	John	Smith	01-Jan-1990	Male	15-21
2	123456	123456-002	Robert	Great	25-Jun-1967	Male	75-90
3	123456	123456-003	Adele	Rose	18-Sep-1987	Male	25-30
4	123457	123457-001	Angelica	Johnson	11-Feb-1978	Female	40-50
5	123457	123457-002	Oliver	Anderson	06-May-1970	Male	40-50

Any help will be much appreciated.

Thanks
Omer.

Try

Sub test()
    Dim a, i As Long, ii As Long, dic As Object, AL As Object
    Dim m As Object, n As Long, myItems As Long, e, s
    Set dic = CreateObject("Scripting.Dictionary")
    Set AL = CreateObject("System.Collections.ArrayList")
    a = Sheets("sheet1").Cells(1).CurrentRegion.Value
    With CreateObject("VBScript.RegExp")
        .Global = True
        .Pattern = "([^~:]+) *:([^~]+)"
        For i = 2 To UBound(a, 1)
            If Not dic.exists(a(i, 2)) Then
                Set dic(a(i, 2)) = CreateObject("Scripting.Dictionary")
            End If
            n = 0
            For ii = 3 To UBound(a, 2)
                If a(i, ii) <> "" Then
                    n = n + 1
                    Set dic(a(i, 2))(n) = CreateObject("Scripting.Dictionary")
                    If .test(a(i, ii)) Then
                        For Each m In .Execute(a(i, ii))
                            If Not AL.Contains(m.submatches(0)) Then AL.Add m.submatches(0)
                            dic(a(i, 2))(n)(m.submatches(0)) = m.submatches(1)
                        Next
                    End If
                    myItems = myItems + dic(a(i, 2))(n).Count
                End If
            Next
        Next
    End With
    ReDim a(1 To myItems, 1 To AL.Count + 3): n = 1
    With Sheets("sheet1")
        a(n, 1) = .Cells(1, 1).Value: a(n, 2) = .Cells(1, 2).Value
        a(n, 3) = Split(.Cells(1, 3).Value)(0)
    End With
    For i = 0 To AL.Count - 1: a(1, i + 4) = AL(i): Next
    For Each e In dic
        For i = 0 To dic(e).Count - 1
            n = n + 1: a(n, 1) = n - 1: a(n, 2) = e: a(n, 3) = e & Format$(i + 1, "-000")
            For Each s In dic(e).items()(i).keys
                a(n, AL.IndexOf(s, 0) + 4) = "'" & dic(e).items()(i)(s)
            Next
        Next
    Next
    With Sheets("sheet2").Cells(1).Resize(n, UBound(a, 2))
        .CurrentRegion: .ClearContents
        .Value = a: .Parent.Select
    End With
End Sub

Try this:-
Results sheet2

Sub MG27Mar25
Dim Ray, Rng As Range, c As Long, Sp As Variant, Ac As Long, Rw As Long
Dim n As Long, Num As Long
Ray = Range("A1").CurrentRegion
ReDim nray(1 To UBound(Ray, 1) * UBound(Ray, 2), 1 To 8)
nray(1, 1) = "RowID": nray(1, 2) = "LocationID": nray(1, 3) = "EmployeeID":
nray(1, 4) = "First Name": nray(1, 5) = "Last Name": nray(1, 6) = "DOB": nray(1, 7) = "Gender": nray(1, 8) = "Salary Range"
c = 1
For Rw = 2 To UBound(Ray, 1)
Num = 1
 For Ac = 3 To UBound(Ray, 2)
      If Not Ray(Rw, Ac) = vbNullString Then
        c = c + 1
        nray(c, 1) = c - 1: nray(c, 2) = Ray(Rw, 2): nray(c, 3) = Ray(Rw, 2) & "-" & Format(Num, "000")
        Sp = Split(Ray(Rw, Ac), "~")
        Num = Num + 1
        For n = 0 To UBound(Sp)
            nray(c, n + 4) = Split(Sp(n), ":")(1)
        Next n
      End If
  Next Ac
Next Rw
With Sheets("Sheet2").Range("A1").Resize(c, 8)
    .Value = nray
    .Columns.AutoFit
End With
End Sub

Regards Mick

WOW Perfect ... you are a super star

It works great.

I am quite novice in VB, do you mind explaining the code so i can have a better understanding on how you did it. It may help others who try to do the same thing.

Thank you so very much.
Omer.