فك خلية مواد الرسوب الافقية الى خلايا طولية

[خير الايمان]

السلام عليكم ورحمة الله وبركاته

اساتذتي الكرام
دمتم بكل الخير
مرفق ملف به جدول مواد رسوب والطلوب من حاضرتكم تحويله كما هو موضح بالملف
دمتم بالصحة والعافية
تقديري

1.rar

[أبومروان]

وعليكم السلام ورحمه الله وبركاته 

اليك الحل بالكود لعله يكون المطلوب 👇

Sub SeparateSubjects()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long, j As Long
    Dim outputRow As Long
    Dim subjects() As String
    Dim subject As Variant
    
    Set ws = ThisWorkbook.Sheets(1)
    

    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
    
    outputRow = 6
    
   
    ws.Range("D6:E1000").ClearContents
    
    
    For i = 6 To lastRow
       
        Dim subjectsText As String
        subjectsText = ws.Cells(i, "C").Value
        
   
        Dim seatNumber As String
        seatNumber = ws.Cells(i, "b").Value
        
        subjects = Split(subjectsText, " - ")
         
        For j = LBound(subjects) To UBound(subjects)
            ws.Cells(outputRow, "D").Value = seatNumber
            ws.Cells(outputRow, "E").Value = Trim(subjects(j))
            outputRow = outputRow + 1
        Next j
    Next i
    
    MsgBox "تم فصل المواد بنجاح!", vbInformation
End Sub

 

بالكود.xlsm