VBA (Excel): Split two adjoining columns with comma separated values into new rows

csv_split.vb

' Excel VBA Macro: This takes two adjoining csv cells and splits them into new rows. it will skip rows that don't have commas. You need to manually define the range of cells you want affected. You need to make sure both cells have an equal number of comma separated values.

Sub RedistributeData()
  Dim X As Long, LastRow As Long, A As Range, Table As Range, Data1() As String, Data2() As String
  Dim DelimitedColumn1 As String, DelimitedColumn2 As String
  Const Delimiter As String = ", "
  TableColumns = InputBox("Select column range...")
  Const StartRow As Long = 2
  DelimitedColumn1 = InputBox("First delimited column letter designation...")
  If DelimitedColumn1 = "" Or DelimitedColumn1 Like "*[!A-Za-z]*" Then Exit Sub
      DelimitedColumn2 = InputBox("Second delimited column letter designation...")
  If DelimitedColumn2 = "" Or DelimitedColumn2 Like "*[!A-Za-z]*" Then Exit Sub
  Application.ScreenUpdating = False
  LastRow = Columns(TableColumns).Find(What:="*", SearchOrder:=xlRows, _
            SearchDirection:=xlPrevious, LookIn:=xlFormulas).Row
  For X = LastRow To StartRow Step -1
    Data1 = Split(Cells(X, DelimitedColumn1), Delimiter)
    Data2 = Split(Cells(X, DelimitedColumn2), Delimiter)
    If UBound(Data1) > 0 Then
      Intersect(Rows(X + 1), Columns(TableColumns)).Resize(UBound(Data1)).Insert xlShiftDown
    End If
    If Len(Cells(X, DelimitedColumn1)) Then
      Cells(X, DelimitedColumn1).Resize(UBound(Data1) + 1) = WorksheetFunction.Transpose(Data1)
    End If
    If Len(Cells(X, DelimitedColumn2)) Then
      Cells(X, DelimitedColumn2).Resize(UBound(Data2) + 1) = WorksheetFunction.Transpose(Data2)
    End If
  Next
  LastRow = Cells(Rows.Count, DelimitedColumn1).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(DelimitedColumn1).SpecialCells(xlFormulas).Clear
    Table.Value = Table.Value
  End If
  On Error GoTo 0
  Application.ScreenUpdating = True
End Sub