Option Explicit
Sub abc()
Dim c As Range, rng As Range
Dim i As Long, ii As Long, n As Long
Dim sLoc As String, sItem As String, sDesc As String, sID As String, sQty As String, sSeq As String
Dim aValues(), x
ReDim aValues(1 To Rows.Count, 1 To 6)
Set rng = Range("f1", Cells(Rows.Count, "f").End(xlUp))
For Each c In rng
x = Split(c, ",")
If Not c.Offset(0, -1) = vbNullString Then
sItem = c.Offset(0, -5)
sDesc = c.Offset(0, -4)
sID = c.Offset(0, -3)
sQty = c.Offset(0, -2)
sSeq = c.Offset(0, -1)
sLoc = Left$(x(0), 1)
End If
For i = 0 To UBound(x)
If InStr(1, x(i), "-", vbTextCompare) > 0 Then
For ii = CLng(Trim$(Split(x(i), "-")(0))) To Trim$(Split(x(i), "-")(1))
n = n + 1
aValues(n, 1) = sItem
aValues(n, 2) = sDesc
aValues(n, 3) = sID
aValues(n, 4) = sQty
aValues(n, 5) = sSeq
aValues(n, 6) = sLoc & ii
Next
Else
n = n + 1
If i = 0 Then
aValues(n, 6) = x(i)
Else
aValues(n, 6) = sLoc & x(i)
End If
End If
aValues(n, 1) = sItem
aValues(n, 2) = sDesc
aValues(n, 3) = sID
aValues(n, 4) = sQty
aValues(n, 5) = sSeq
Next
Next
With Worksheets.Add(After:=Worksheets(Worksheets.Count))
.Range("a1").Resize(n, UBound(aValues, 2)) = aValues
End With
End Sub
Bookmarks