Transform Multi-Line to Single-Line Rows
Sub TransformToSingleLine()
Const PROC_TITLE As String = "Transform to Single Line"
' Define constants.
' Source
Const SRC_SHEET_NAME As String = "Sheet1"
Const SRC_FIRST_HEADER_CELL_ADDRESS As String = "A1"
Const SRC_MULTI_LINE_COLUMN As Long = 4
Const SRC_MULTI_LINE_DELIMITER As String = vbLf ' could be 'vbCrLf'
' Destination
Const DST_SHEET_NAME As String = "Sheet2"
Const DST_FIRST_HEADER_CELL_ADDRESS As String = "A1"
' Other
Const KEEP_BLANKS As Boolean = True
Const DISPLAY_MESSAGES As Boolean = True
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Read (source range to source array, source array to split array).
' Reference.
Dim sws As Worksheet: Set sws = wb.Sheets(SRC_SHEET_NAME)
Dim scell As Range: Set scell = sws.Range(SRC_FIRST_HEADER_CELL_ADDRESS)
Dim srg As Range:
With scell.Cells(1).CurrentRegion
Set srg = scell.Resize(.Row + .Rows.Count - scell.Row, _
.Column + .Columns.Count - scell.Column)
End With
' Check rows.
Dim srCount As Long: srCount = srg.Rows.Count
If srCount < 2 Then
If DISPLAY_MESSAGES Then
MsgBox "No data found!", vbExclamation, PROC_TITLE
End If
Exit Sub
End If
' Check columns.
Dim cCount As Long: cCount = srg.Columns.Count
If cCount < SRC_MULTI_LINE_COLUMN Then
If DISPLAY_MESSAGES Then
MsgBox "Not enough columns!", vbExclamation, PROC_TITLE
End If
Exit Sub
End If
' Source values to array.
Dim sData() As Variant: sData = srg.Value
Dim Splits() As Variant: ReDim Splits(1 To srCount, 1 To 2)
Dim drCount As Long: drCount = 1 ' skip headers
Dim sr As Long
' 1st column will hold the 'split' arrays, 2nd column their upper limits.
' Most importantly, 'drCount' will hold the number of destination rows.
For sr = 2 To srCount
Splits(sr, 1) = Split(CStr(sData(sr, SRC_MULTI_LINE_COLUMN)), _
SRC_MULTI_LINE_DELIMITER)
Splits(sr, 2) = UBound(Splits(sr, 1))
drCount = drCount + Splits(sr, 2) + 1 _
+ KEEP_BLANKS * (Splits(sr, 2) = -1)
Next sr
' Transform (source array (split array) to destination array).
Dim dData() As Variant: ReDim dData(1 To drCount, 1 To cCount)
drCount = 1 ' skip headers
Dim c As Long, n As Long
' Write headers.
For c = 1 To cCount
dData(1, c) = sData(1, c)
Next c
' Write data.
For sr = 2 To srCount
Select Case Splits(sr, 2)
Case -1
If KEEP_BLANKS Then
drCount = drCount + 1
For c = 1 To cCount
dData(drCount, c) = sData(sr, c)
Next c
End If
Case 0
drCount = drCount + 1
For c = 1 To cCount
dData(drCount, c) = sData(sr, c)
Next c
Case Else
For n = 0 To Splits(sr, 2)
drCount = drCount + 1
For c = 1 To cCount
If c = SRC_MULTI_LINE_COLUMN Then
dData(drCount, c) = Splits(sr, 1)(n)
Else
dData(drCount, c) = sData(sr, c)
End If
Next c
Next n
End Select
Next sr
' Write (destination array to destination range).
' Reference.
Dim dws As Worksheet: Set dws = wb.Sheets(DST_SHEET_NAME)
Dim dcell As Range: Set dcell = dws.Range(DST_FIRST_HEADER_CELL_ADDRESS)
Dim drg As Range: Set drg = dcell.Resize(drCount, cCount)
' Clear.
dcell.Resize(dws.Rows.Count - dcell.Row + 1, cCount).Clear
' Write.
drg.Value = dData
' Format e.g.:
drg.Rows(1).Font.Bold = True
drg.EntireColumn.AutoFit
' Inform.
If DISPLAY_MESSAGES Then
MsgBox "Data transformed to single line.", vbInformation, PROC_TITLE
End If
End Sub