Revisiting Redistribute a Delimited Column Of Data into Separate Rows

[Rick Rothstein]

Better yet, is it possible to combine this code with your code for Generalized Series Expansions to create a super tool that can handle almost anything and separate them into individual rows. I have very little coding knowledge, so quite frankly, I am humbly asking if it would be possible for you to find some time to modify your code.

Easy enough to do, simply include the ExpandedSeries function in the same module as the RedistributeData macro and modify one line of code (highlighted in red below) in the RedistributeData macro to accommodate the call to the ExpandedSeries 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 = "C"
  Const TableColumns As String = "A:C"
  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(ExpandedSeries(Cells(X, DelimitedColumn), Delimiter), 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

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(-(Numbers(1) > 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

Note: Leave the delimiters as I have them set... do not try to change them.