---

Sub SplitRowsToNewSheet()

    Dim wsSource As Worksheet
    Dim wsResult As Worksheet
    Dim lastRow As Long
    Dim resultRow As Long
    Dim i As Long
    Dim j As Long
    Dim parts As Variant
    
    ' Исходный лист
    Set wsSource = ActiveSheet
    
    ' Создаем новый лист
    Set wsResult = Worksheets.Add(After:=Worksheets(Worksheets.Count))
    wsResult.Name = "Результат"
    
    ' Последняя строка исходных данных
    lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
    
    ' Копируем заголовки
    wsResult.Cells(1, "A").Value = wsSource.Cells(1, "A").Value
    wsResult.Cells(1, "B").Value = wsSource.Cells(1, "B").Value
    
    resultRow = 2
    
    ' Обрабатываем строки
    For i = 2 To lastRow
        
        ' Разбиваем значение столбца B по разделителю |
        parts = Split(wsSource.Cells(i, "B").Value, "|")
        
        ' Записываем каждую часть на отдельную строку
        For j = 0 To UBound(parts)
            
            ' Сохраняем значение из столбца A
            wsResult.Cells(resultRow, "A").Value = wsSource.Cells(i, "A").Value
            
            ' Записываем разбитое значение в столбец B
            wsResult.Cells(resultRow, "B").Value = Trim(parts(j))
            
            resultRow = resultRow + 1
            
        Next j
        
    Next i
    
    ' Автоматическая ширина столбцов
    wsResult.Columns("A:B").AutoFit

End Sub