Text to row

Hello All,
I posted this question before and I got the answer for it, but after further analysis, i found out an error in the result. so please look at the attached file to understand my request. you can also find below the code i have been useing.

Sub MakeTheList()
    
    Dim arr As Variant
    Dim r As Long, c As Long
    Dim DestR As Long
    Dim Countries As Variant
    
    arr = ActiveSheet.UsedRange.Value
    Worksheets.Add
    [a1:e1] = Array("Country Code", "date", "value", "points", "City Code")
    
    DestR = 1
    
    For r = 2 To UBound(arr, 1)
    
    If arr(r, 5) = "" Then
            Cells(DestR, 1) = arr(r, 1)
            Cells(DestR, 2) = arr(r, 2)
            Cells(DestR, 3) = arr(r, 3)
            Cells(DestR, 4) = arr(r, 4)
            Cells(DestR, 5) = arr(r, 5)
           End If
        Countries = Split(arr(r, 5), ",")
        For c = 0 To UBound(Countries)
            DestR = DestR + 1
            Cells(DestR, 1) = arr(r, 1)
            Cells(DestR, 2) = arr(r, 2)
            Cells(DestR, 3) = arr(r, 3)
            Cells(DestR, 4) = arr(r, 4)
            Cells(DestR, 5) = Trim(Countries(c))
           
        Next
    Next
    

End Sub

Select all Open in new window

Problem.xlsx