Sub fff()
Dim i As Long, n As Long, lr As Long
Dim cell As Range
Dim arr, arr2
Dim sh1 As Worksheet, sh2 As Worksheet
Set sh1 = Worksheets("Лист1")
Set sh2 = Worksheets("Лист2")
sh2.Range("A2:D123456").ClearContents
lr = sh1.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lr
    arr = Split(sh1.Cells(i, 3), ",")
    For k = 1 To UBound(arr)
        lr2 = sh2.Cells(Rows.Count, 1).End(xlUp).Row + 1
        sh2.Cells(lr2, 1) = arr(k)
        sh2.Cells(lr2, 3) = CDate(sh1.Cells(i, 1))
        sh2.Cells(lr2, 2) = sh1.Cells(i, 2)
    Next k
Next i
For i = 2 To lr
    arr2 = Split(sh1.Cells(i, 4), ",")
    For k = 1 To UBound(arr2)
    Set cell = sh2.Columns(1).Find(arr2(k))
    If Not cell Is Nothing Then sh2.Cells(cell.Row, 4) = CDate(sh1.Cells(i, 1))
    Next k
    
Next i
End Sub