Give this a go on your 'real' data set...
Tested on 25 000 rows took about 3 seconds..
Private Sub CommandButton1_Click()
Dim x, y, cnt As Long, k As Long, s As Long, j As Long, i As Long, ii As Long
With Range("A1").CurrentRegion
x = .Offset(1).Resize(.Rows.Count - 1).Value
cnt = 1: k = 1: s = 1
ReDim y(1 To UBound(Split(Replace(Join(Application.Transpose(.Columns(7).Offset(1).Resize(.Rows.Count - 1).Value), vbLf), vbLf, ";"), ";")) + 1, 1 To 13)
For i = 1 To UBound(y)
For j = 0 To UBound(Split(x(cnt, 7), ";"))
For ii = 1 To UBound(x, 2)
If ii = 7 Then
y(k, ii) = Trim(Split(x(cnt, 7), ";")(j))
ElseIf ii = 8 Then
y(k, ii) = Trim(Split(x(cnt, 8), ";")(j))
Else
y(k, ii) = Trim(x(cnt, ii))
End If
Next ii
If s = UBound(Split(x(cnt, 7), ";")) + 1 Then
k = k + 1: cnt = cnt + 1: Exit For
Else
k = k + 1: s = s + 1
End If
Next j
s = 1
If k > UBound(y) Then
With Sheets("Sheet2")
.Range("A2").Resize(UBound(y), 13).Value = y
.Columns.AutoFit
.Columns(5).NumberFormat = "0"
.Select
End With
Exit Sub
End If
Next i
End With
End Sub
Bookmarks