Sub ExpandRefDes()
Dim Cell As Range
For Each Cell In Range("H2:H" & Cells(Rows.Count, "H").End(xlUp).Row)
Cell.Value = ExpandedSeries(Replace(Cell.Value, ",", "," & Left(Cell.Value, 1)), ",")
Next
RedistributeData
Range("J2:J" & Cells(Rows.Count, "J").End(xlUp).Row).Value = 1
End Sub
Function ExpandedSeries(ByVal S As String, Optional Delimiter As String = ", ") As Variant
Dim X As Long, Y As Long, Z As Long
Dim Letter As String, Numbers() As String, Parts() As String
S = Chr$(1) & Replace(Replace(Replace(Replace(Application.Trim(Replace(S, ",", _
" ")), " -", "-"), "- ", "-"), " ", " " & Chr$(1)), "-", "-" & Chr$(1))
Parts = Split(S)
For X = 0 To UBound(Parts)
If Parts(X) Like "*-*" Then
For Z = 1 To InStr(Parts(X), "-") - 1
If IsNumeric(Mid(Parts(X), Z, 1)) And Mid$(Parts(X), Z, 1) <> "0" Then
Letter = Left(Parts(X), Z + (Left(Parts(X), 1) Like "[A-Za-z" & Chr$(1) & "]"))
Exit For
End If
Next
Numbers = Split(Replace(Parts(X), Letter, ""), "-")
If Not Numbers(1) Like "*[!0-9" & Chr$(1) & "]*" Then Numbers(1) = Val(Replace(Numbers(1), Chr$(1), "0"))
On Error GoTo SomethingIsNotRight
For Z = Numbers(0) To Numbers(1) Step Sgn(-(CDbl(Numbers(1)) > CDbl(Numbers(0))) - 0.5)
ExpandedSeries = ExpandedSeries & Delimiter & Letter & Z
Next
Else
ExpandedSeries = ExpandedSeries & Delimiter & Parts(X)
End If
Next
ExpandedSeries = Replace(Mid(ExpandedSeries, Len(Delimiter) + 1), Chr$(1), "")
Exit Function
SomethingIsNotRight:
ExpandedSeries = CVErr(xlErrValue)
End Function
Sub RedistributeData()
Dim X As Long, LastRow As Long, A As Range, Table As Range, Data() As String
Const Delimiter As String = ","
Const DelimitedColumn As String = "H"
Const TableColumns As String = "A:O"
Const StartRow As Long = 2
Application.ScreenUpdating = False
LastRow = Columns(TableColumns).Find(What:="*", SearchOrder:=xlRows, _
SearchDirection:=xlPrevious, LookIn:=xlFormulas).Row
For X = LastRow To StartRow Step -1
Data = Split(Cells(X, DelimitedColumn), Delimiter)
If UBound(Data) > 0 Then
Intersect(Rows(X + 1), Columns(TableColumns)).Resize(UBound(Data)).Insert xlShiftDown
End If
If Len(Cells(X, DelimitedColumn)) Then
Cells(X, DelimitedColumn).Resize(UBound(Data) + 1) = WorksheetFunction.Transpose(Data)
End If
Next
LastRow = Cells(Rows.Count, DelimitedColumn).End(xlUp).Row
On Error Resume Next
Set Table = Intersect(Columns(TableColumns), Rows(StartRow).Resize(LastRow - StartRow + 1))
If Err.Number = 0 Then
Table.SpecialCells(xlBlanks).FormulaR1C1 = "=R[-1]C"
Columns(DelimitedColumn).SpecialCells(xlFormulas).Clear
Table.Value = Table.Value
End If
On Error GoTo 0
Application.ScreenUpdating = True
End Sub
