Option Explicit
Private Const m_SPLIT_COLUMN As String = "G"
Sub SplitData()
Dim values As Variant
Dim newSheet As Worksheet, sheet As Worksheet
Dim currentRow As Long, lastRow As Long, newRow As Long
Dim lastStaticColumn As String
Set sheet = ActiveWorkbook.ActiveSheet
' Create new sheet.
With ActiveWorkbook.Sheets
Set newSheet = .Add(after:=.Item(.Count))
End With
' Copy headers.
newRow = 1
Call CopyEntireRow(1, sheet, newSheet, newRow)
' Defined to be 1 column to the left of the split data.
lastStaticColumn = Chr$(Asc(m_SPLIT_COLUMN) - 1)
With sheet
.Activate
lastRow = .Cells.SpecialCells(xlCellTypeLastCell).Row
For currentRow = 2 To lastRow
.Activate
If Application.WorksheetFunction.IsErr(.Cells(currentRow, m_SPLIT_COLUMN).Value) Then
Call CopyEntireRow(currentRow, sheet, newSheet, newRow)
Else
If Len(Trim$(.Cells(currentRow, m_SPLIT_COLUMN).Value)) > 0 Then
' Create 1s based array based upon comma delimited list.
values = GetSplitValues(currentRow, m_SPLIT_COLUMN, sheet)
' Copy array directly to corresponding range on new sheet.
With newSheet
.Select
.Range(.Cells(newRow, m_SPLIT_COLUMN), .Cells(newRow + UBound(values) - 1, m_SPLIT_COLUMN)).Value = values
End With
' Copy static data to corresponding new rows created by copying the array above.
Call CopyRemainingRowData(currentRow, "A", lastStaticColumn, values, sheet, newSheet, newRow)
End If
End If
' Added a blank line to make verification easier.
newRow = newRow + 1
Next
End With
newSheet.Cells.EntireColumn.AutoFit
MsgBox "Completed"
End Sub 'SplitData
Private Sub CopyEntireRow(ByVal currentRow As Long, ByVal currentSheet As Worksheet, ByVal targetSheet As Worksheet, ByRef newRow As Long)
Dim active As Worksheet
Set active = ActiveWorkbook.ActiveSheet
With currentSheet
.Activate
.Cells(currentRow, "A").Select
.Range(Selection, Selection.End(xlToRight)).Copy
End With
With targetSheet
.Select
.Cells(newRow, "A").Select
.Paste
End With
newRow = newRow + 1
active.Activate
Set active = Nothing
End Sub 'CopyEntireRow
Private Function GetSplitValues(ByVal currentRow, ByVal splitColumn As String, ByVal currentSheet As Worksheet) As Variant
Dim index As Long
Dim values As Variant
Dim active As Worksheet
Set active = ActiveWorkbook.ActiveSheet
' Create array by splitting comma delimited list.
' Alternatively, you could use a Regular Expression split which would handle whitespace and make the trim loop unneeded.
With currentSheet
.Select
values = Split(.Cells(currentRow, m_SPLIT_COLUMN).Value, ",")
End With
' Trim them all.
For index = LBound(values) To UBound(values)
values(index) = Trim$(values(index))
Next
' Convert to 1s based array.
values = Application.WorksheetFunction.Transpose(values)
active.Activate
Set active = Nothing
GetSplitValues = values
End Function 'GetSplitValues
Private Sub CopyRemainingRowData(ByVal currentRow As Long, ByVal firstColumn As String, ByVal lastColumn As String, ByVal values As Variant, ByVal currentSheet As Worksheet, ByVal targetSheet As Worksheet, ByRef newRow As Long)
Dim active As Worksheet
Set active = ActiveWorkbook.ActiveSheet
With currentSheet
.Select
.Range(.Cells(currentRow, firstColumn), .Cells(currentRow, lastColumn)).Copy
End With
With targetSheet
.Select
.Paste Destination:=.Range(.Cells(newRow, firstColumn), .Cells(newRow + UBound(values) - 1, lastColumn))
End With
newRow = newRow + UBound(values)
active.Activate
Set active = Nothing
End Sub 'CopyRemainingRowData
