Option
Explicit
Sub
DoIt()
Dim
WsAct
As
Worksheet
Dim
WsTmp
As
Worksheet
Dim
rngUsed
As
Range
Dim
rngRow
As
Range
Dim
arrDt2()
As
String
Dim
x
As
Integer
Application.ScreenUpdating =
False
Set
WsAct = ActiveSheet
Set
WsTmp = Sheets.Add(After:=Sheets(WsAct.Index))
Set
rngUsed = WsAct.UsedRange
rngUsed.Rows(1).Copy WsTmp.Cells(1)
Set
rngUsed = rngUsed.Offset(1).Resize(rngUsed.Rows.Count - 1)
For
Each
rngRow
In
rngUsed.Rows
If
IsEmpty(rngRow.Cells(4))
Or
InStr(rngRow.Cells(4),
";"
) = 0
Then
rngRow.Copy WsTmp.Cells(WsTmp.Rows.Count, 1).
End
(xlUp).Offset(1)
Else
arrDt2 = Split(rngRow.Cells(4),
";"
)
For
x = LBound(arrDt2)
To
UBound(arrDt2)
rngRow.Copy WsTmp.Cells(WsTmp.Rows.Count, 1).
End
(xlUp).Offset(1)
WsTmp.Cells(WsTmp.Rows.Count, 1).
End
(xlUp).Offset(, 3) = arrDt2(x)
Next
x
End
If
Next
rngRow
WsTmp.UsedRange.Copy WsAct.Cells(1)
Application.DisplayAlerts =
False
WsTmp.Delete
WsAct.Activate
Application.DisplayAlerts =
True
Set
WsAct =
Nothing
Set
WsTmp =
Nothing
Application.ScreenUpdating =
True
End
Sub