How to remove empty lines from cells in Excel (VBA) - vba

Question

Here's what I'm trying to achieve through all the cells in the worksheet containing a string, with limited success so far:
| EXAMPLE |
cell1_empty_line
cell1_text1
cell1_empty_line
+---------------------+
cell2_text1
cell2_emptyline
cell2_text2
+---------------------+
cell3_emptyline
cell3_emptyline
cell3_text1
+---------------------+
| EXPECTED RESULT |
cell1_text1
+---------------------+
cell2_text1
cell2_text2
+---------------------+
cell3_text1
+---------------------+
Any suggestion for such a macro?
Many thanks.

Answer 1

Use this macro to remove any empty lines inside all cells:
Sub TrimEmptyLines()
Dim cel As Range, s As String, len1 As Long, len2 As Long
For Each cel In ActiveSheet.UsedRange
If Not IsError(cel.Value2) Then
If InStr(1, cel.text, vbLf) > 0 Then
s = Trim(cel.Value2)
Do ' remove duplicate vbLf
len1 = Len(s)
s = Replace$(s, vbLf & vbLf, vbLf)
len2 = Len(s)
Loop Until len2 = len1
' remove vblf at beginning or at end
If Left$(s, 1) = vbLf Then s = Right$(s, Len(s) - 1)
If Right$(s, 1) = vbLf Then s = Left$(s, Len(s) - 1)
cel.value = Trim$(s)
End If
End If
Next
End Sub

Answer 2

This is general enough to handle any column of cells with any # of line feeds in each cell. It assumes all your values are in column "A" starting at row 1 of the active sheet:
Public Function RemoveDoubleLfs(str As String) As String
If InStr(str, vbLf & vbLf) > 0 Then
str = RemoveDoubleLfs(Replace(str, vbLf & vbLf, vbLf))
End If
RemoveDoubleLfs = str
End Function
Sub RemoveEmptyLines()
Dim i As Integer, lastRow As Integer
lastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row '
Dim val As String
For i = 1 To lastRow:
val = Cells(i, "A").Value
If InStr(1, val, vbLf) > 0 Then
val = RemoveDoubleLfs(val)
If Left(val, 1) = vbLf Then val = Right(val, Len(val) - 1)
If Right(val, 1) = vbLf Then val = Left(val, Len(val) - 1)
Cells(i, "A").Value = val
End If
Next
ActiveSheet.Rows.EntireRow.AutoFit
End Sub
The recursive replace function gets rid of double line feeds in the text of the cell. Once that's done there will be at most one VbLf at the beginning and end of the string. The last two if statements look for and remove the latter.
The autofit at the end is optional and is there purely to prettify the result; it just compacts the cells to their minimum height.

Answer 3

If you are working with just one cell and its blank lines within then one of these should work:
Cells.Replace what:=Chr(13), Replacement:="", LookAt:=xlPart
Cells.Replace what:=Chr(10), Replacement:="", LookAt:=xlPart

Answer 4

Before implementing this solution please set the values of the two variables at the top.
FirstDataColumn = 1
FirstDataRow = 2
This setting leaves starts with the first column but leaves out the first row which might contain column captions.
Sub RemoveBlanks()
Dim FirstDataColumn As Long, FirstDataRow As Long
Dim LastColumn As Long, LastRow As Long
Dim Tmp As Variant, Arr As Variant
Dim Counter As Integer
Dim C As Long, R As Long
FirstDataColumn = 1
FirstDataRow = 2
Application.ScreenUpdating = False
With ActiveSheet
With .UsedRange
LastColumn = .Columns.Count
LastRow = .Rows.Count
End With
For C = FirstDataColumn To LastColumn
ReDim Arr(LastRow, 0)
Counter = 0
For R = FirstDataRow To LastRow
Tmp = Trim(.Cells(R, C).Value)
If Len(Tmp) Then
Arr(Counter, 0) = Tmp
Counter = Counter + 1
End If
Next R
.Cells(FirstDataRow, C).Resize(LastRow, 1).Value = Arr
Next C
End With
Application.ScreenUpdating = True
End Sub