Manage multivalued attributes

This version caters for the scenario where there is a Request ID but no associated Linked Services.

' Module: mOneToMany_V2

'Option Private Module
Option Explicit

Sub sOneToMany_V2()

Dim lLR As Long, lNR As Long
Dim i As Long, j As Long
Dim vx1, vy2, vRequest
Const sInput As String = "Sheet1"
Const sOutput As String = "Sheet2"

Dim sw As New StopWatch
sw.StartTimer
Debug.Print "Start: ", Time
    
Application.ScreenUpdating = False
Sheets(sOutput).Cells.Delete

With Sheets(sInput)
    lLR = .Range("A" & Rows.Count).End(xlUp).Row
    .Range("A1:B1").Copy _
        Sheets(sOutput).Range("A1")
End With

For i = 2 To lLR
    With Sheets(sInput)
        vRequest = .Range("A" & i)
        If .Range("B" & i) = "" Then GoTo lblSkip
        vx1 = Split(.Range("B" & i), ",")
        ReDim vy2(LBound(vx1) To UBound(vx1), 1 To 2)
        For j = LBound(vx1) To UBound(vx1)
            vy2(j, 1) = vRequest: vy2(j, 2) = vx1(j)
        Next 'j
    End With
    With Sheets(sOutput)
        lNR = .Range("B" & .Rows.Count).End(xlUp).Row + 1
        .Range("A" & lNR).Resize(UBound(vx1) + 1, 2).Value = vy2
    End With
    GoTo lblNext

lblSkip:
    With Sheets(sOutput)
        lNR = .Range("B" & .Rows.Count).End(xlUp).Row + 1
        .Range("A" & lNR) = vRequest
        .Range("B" & lNR) = "$$no entries$$"
    End With

lblNext:
Next 'i

With Sheets(sOutput).Range("A1:B1").EntireColumn
    .Replace What:="$$no entries$$", _
             Replacement:="", _
             LookAt:=xlWhole
    .AutoFit
End With

Application.ScreenUpdating = True

Debug.Print "End: ", Time
Debug.Print "sOneToMany took: " & sw.EndTimer & " milliseconds."

End Sub

Regards, TMS