This is a direct follow up to Parsing cells containing Line Feed Characters.
Link to sanitized xls on dropbox if test data is needed
Essentially the reports I work with aren't bad -
The issue is the way it exports to excel -
With the problem being that these cells are filled with LF characters breaking apart the data entries in the cells (usually a listing of employees in format empID / emp name. There's really no rhyme or reason as to where it places the LFs - sometimes there are three in a row.
A lot of the time for analysis I need to use this data but first I need each person to have their own data (the reports get a lot bigger).
I implemented most changes in the answers from last time, but I've never worked with Enum before or custom error handling. Also, this was initially developed in 2010, but this time I wrote it in 2016, if that matters.
Code
All one module. Two procedures - parse into columns and parse into rows.
Private Enum ParseError
InputRangeIsNothing = vbObjectError + 42
MultipleColumnsSelected = vbObjectError + 43
ProcessCancelled = vbObjectError + 44
NoOverwrite = vbObjectError + 45
NoData = vbObjectError + 46
End Enum
Public Sub ParseIntoColumns()
'Parse column to the right (text to columns)
On Error GoTo ErrHandler
Dim confirmOverwrite As String
confirmOverwrite = MsgBox("Do you want to overwrite all data to the right of your selection?", vbYesNo)
If confirmOverwrite = vbNo Then Err.Raise ParseError.NoOverwrite
Dim lastRow As Long
lastRow = 1
Dim workingRange As Range
Set workingRange = UserSelectRange(lastRow)
If workingRange Is Nothing Then Err.Raise ParseError.InputRangeIsNothing
Dim workingSheet As Worksheet
Set workingSheet = workingRange.Parent
Dim workingColumn As Long
workingColumn = workingRange.Column
Application.ScreenUpdating = False
Application.DisplayAlerts = False
workingRange.TextToColumns _
Destination:=workingRange, _
DataType:=xlDelimited, _
TextQualifier:=xlTextQualifierNone, _
ConsecutiveDelimiter:=True, _
Tab:=False, _
Semicolon:=False, _
Comma:=False, _
Space:=False, _
Other:=True, OtherChar:=vbLf
Application.DisplayAlerts = True
With workingSheet.UsedRange
.WrapText = False
.EntireColumn.AutoFit
End With
Application.ScreenUpdating = True
Exit Sub
ErrHandler:
Select Case Err.Number
Case ParseError.InputRangeIsNothing
MsgBox "Process cancelled: You have not selected a range.", vbExclamation
Case ParseError.MultipleColumnsSelected
MsgBox "Process cancelled: You may not select more than 1 column at a time", vbExclamation
Case ParseError.ProcessCancelled
MsgBox "Process cancelled", vbExclamation
Case ParseError.NoOverwrite
MsgBox "Process cancelled: Please alter your data structure to allow overwriting cells to the right of your selection.", vbExclamation
Case ParseError.NoData
MsgBox "Process cancelled: your selection does not have data to parse", vbExclamation
Case Else
MsgBox "An error has occured: " & Err.Number & "- " & Err.Description, vbCritical
End Select
End Sub
Public Sub ParseIntoRows()
'Parse column downward, inserting rows
On Error GoTo ErrHandler
Dim lastRow As Long
lastRow = 1
Dim workingRange As Range
Set workingRange = UserSelectRange(lastRow)
If workingRange Is Nothing Then Err.Raise ParseError.InputRangeIsNothing
Application.ScreenUpdating = False
Dim workingColumn As Long
workingColumn = workingRange.Column
Dim currentRow As Long
Dim cellToParse As Range
Dim stringParts() As String
Dim cellContent As String
Dim replacementCellContent As String
Dim numberOfParts As Long
For currentRow = lastRow To 2 Step -1
Set cellToParse = Cells(currentRow, workingColumn)
If Not IsEmpty(cellToParse) Then
cellContent = cellToParse.Value
replacementCellContent = Replace(cellContent, vbLf & vbLf, vbLf)
Do Until cellContent = replacementCellContent
cellContent = replacementCellContent
replacementCellContent = Replace(cellContent, vbLf & vbLf, vbLf)
Loop
stringParts = Split(cellContent, vbLf)
numberOfParts = UBound(stringParts) - LBound(stringParts) + 1
If numberOfParts > 1 Then CreateNewRows stringParts(), numberOfParts, cellToParse
End If
Next currentRow
Application.CutCopyMode = False
Application.ScreenUpdating = True
Exit Sub
ErrHandler:
Select Case Err.Number
Case ParseError.InputRangeIsNothing
MsgBox "Process cancelled: You have not selected a range.", vbExclamation
Case ParseError.MultipleColumnsSelected
MsgBox "Process cancelled: You may not select more than 1 column at a time", vbExclamation
Case ParseError.ProcessCancelled
MsgBox "Process cancelled", vbExclamation
Case ParseError.NoOverwrite
MsgBox "Process cancelled: Please alter your data structure to allow overwriting cells to the right of your selection.", vbExclamation
Case ParseError.NoData
MsgBox "Process cancelled: your selection does not have data to parse", vbExclamation
Case Else
MsgBox "An error has occured: " & Err.Number & "- " & Err.Description, vbCritical
End Select
End Sub
Supporting cast:
Private Sub CreateNewRows(ByRef partsOfString() As String, ByVal numberOfParts As Long, ByVal cellToParse As Range)
With cellToParse
.EntireRow.Copy
.Offset(1, 0).Resize(numberOfParts - 1, 1).EntireRow.Insert
.Resize(numberOfParts, 1).Value = Application.WorksheetFunction.Transpose(partsOfString)
End With
End Sub
Private Function UserSelectRange(ByRef lastRow As Long) As Range
Set UserSelectRange = Nothing
Dim columnToParse As Range
Set columnToParse = GetUserInputRange
If columnToParse Is Nothing Then Err.Raise ParseError.InputRangeIsNothing
If columnToParse.Columns.Count > 1 Then Err.Raise ParseError.MultipleColumnsSelected
lastRow = Cells(Rows.Count, columnToParse.Column).End(xlUp).Row
If lastRow < 2 Then Err.Raise ParseError.NoData
Dim columnLetter As String
columnLetter = ColumnNumberToLetter(columnToParse)
Dim result As String
result = MsgBox("The column you've selected to parse is column " & columnLetter, vbOKCancel)
If result = vbCancel Then Err.Raise ParseError.ProcessCancelled
Set UserSelectRange = Range(Cells(2, columnToParse.Column), Cells(lastRow, columnToParse.Column))
End Function
Private Function GetUserInputRange() As Range
'This is segregated because of how excel handles cancelling a range input
Dim userAnswer As Range
On Error GoTo InputError
Set userAnswer = Application.InputBox("Please click a cell in the column to parse", "Column Parser", Type:=8)
Set GetUserInputRange = userAnswer
Exit Function
InputError:
Set GetUserInputRange = Nothing
End Function
Private Function ColumnNumberToLetter(ByVal selectedRange As Range) As String
'Convert column number to column letter representation
Dim rowBeginningPosition As Long
rowBeginningPosition = InStr(2, selectedRange.Address, "$")
Dim columnLetter As String
columnLetter = Mid(selectedRange.Address, 2, rowBeginningPosition - 2)
'Handles if the user selected an entire column
If Right(columnLetter, 1) = ":" Then
ColumnNumberToLetter = Left(columnLetter, Len(columnLetter) - 1)
Else: ColumnNumberToLetter = columnLetter
End If
End Function
