Try this (backup your data first)
Sub k1()
Dim i, j, k As Long
Dim l As String
lastrow = Worksheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
k = 0
For i = 1 To lastrow
k = k + 1
l = ""
For j = 1 To Len(Worksheets("sheet1").Cells(i, 2))
If Mid(Worksheets("Sheet1").Cells(i, 2), j, 1) = ";" Then
Worksheets("Sheet2").Cells(k, 1) = Worksheets("Sheet1").Cells(i, 1)
Worksheets("Sheet2").Cells(k, 2) = l
Worksheets("Sheet2").Cells(k, 3) = Worksheets("Sheet1").Cells(i, 3)
Worksheets("Sheet2").Cells(k, 4) = Worksheets("Sheet1").Cells(i, 4)
Worksheets("Sheet2").Cells(k, 5) = Worksheets("Sheet1").Cells(i, 5)
k = k + 1: l = ""
Else
l = l & Mid(Worksheets("Sheet1").Cells(i, 2), j, 1)
End If
Next j
Worksheets("Sheet2").Cells(k, 1) = Worksheets("Sheet1").Cells(i, 1)
Worksheets("Sheet2").Cells(k, 2) = l
Worksheets("Sheet2").Cells(k, 3) = Worksheets("Sheet1").Cells(i, 3)
Worksheets("Sheet2").Cells(k, 4) = Worksheets("Sheet1").Cells(i, 4)
Worksheets("Sheet2").Cells(k, 5) = Worksheets("Sheet1").Cells(i, 5)
Next i
End Sub
Bookmarks