Sub tt()

fileToOpen = Application.GetOpenFilename _
        ("Files (*.xls), *.xls,Files (*.xlsx), *.xlsx")
            If fileToOpen <> False Then
                MsgBox "Вы открываете файл " & fileToOpen
                Set wb = Workbooks.Open(fileToOpen)
                Application.ScreenUpdating = False
                uuu wb.Worksheets(1)
                Application.ScreenUpdating = True
            End If

End Sub


Sub uuu(sh)
    Dim rw&, i&
    Dim sp, rg
    With sh
    For rw = .Cells(.Rows.Count, 3).End(xlUp).Row To 2 Step -1 'проходим по ячейкам диапазона от конца к началу
        If .Cells(rw, 3) <> "" Then 'если ячейка не пустая то
            sp = Split(.Cells(rw, 3), "/") 'берём в массив значения ячейки разделитель /
            rg = Array(.Cells(rw, 4), .Cells(rw, 5), .Cells(rw, 6)) '
            For i = UBound(sp) To 0 Step -1 'проходим по значениям массива от конца к началу
                If sp(i) <> "" Then 'если текущее значение не пусто то
                    .Cells(rw + 1, 3).EntireRow.Insert 'добавляем строку
                    .Cells(rw + 1, 2) = sp(i) 'во вторую колонку вносим текущее значение из массива
                    .Cells(rw + 1, 4).Resize(, 3) = rg 'вносим в эту же строку значения ячеек D-F
                End If
            Next
            .Cells(rw, 3).ClearContents 'чистим содержимое текущей ячейки
        End If
    Next
    End With
    Beep
End Sub