このコードは、必要なことだけを行う必要があります
Sub SplitCellsAndExtend_Olddasgf()
'takes cells with inside line feeds and creates new row for each.
'reverses merge into top cell.
Dim strCell As String, lastRow As Long, i As Long, j As Long, sPrefix As String
Const sSplitOn As String = "/"
application.ScreenUpdating = False
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
For i = lastRow To 1 Step -1
strCell = Cells(i, 1)
j = 0
Do While InStr(1, strCell, sSplitOn) > 0
Rows(i + j + 1).Insert
sPrefix = Left(strCell, InStr(strCell, "-"))
strCell = Right(strCell, Len(strCell) - InStr(1, strCell, sSplitOn))
Cells(i + j, 1) = Left(Cells(i + j, 1).Value, InStr(1, Cells(i + j, 1), sSplitOn) - 1)
strCell = sPrefix & strCell
Cells(i + j + 1, 1).Value = strCell
j = j + 1
Loop
Next
application.ScreenUpdating = True
End Sub