Split multiple Delimiter field with Header into Multiple Columns and Rows

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