Count lines of text in a cell
I have an Excel spreadsheet for work that I need to split in VBA. Several columns have multiple lines of text, while others do not. I figured out how to split multiple lines of text, my problem is that the column contains one line of text and copies it. For example:
Company_Name Drug_1 Phase_2 USA
Drug_2 Discontinued
Drug_3 Phase_1 Europe
Drug_4 Discontinued
Below is the code I am using to split columns B and C and then I can handle D manually, however I need column A to copy to rows 2-4. There are over 600 lines like this, I would just do it manually. (Note: I put columns B in below and column C in C)
Sub Splitter()
Dim iPtr1 As Integer
Dim iPtr2 As Integer
Dim iBreak As Integer
Dim myVar As Integer
Dim strTemp As String
Dim iRow As Integer
'column A loop
iRow = 0
For iPtr1 = 1 To Cells(Rows.Count, 1).End(xlUp).Row
strTemp = Cells(iPtr1, 1)
iBreak = InStr(strTemp, vbLf)
Range("C1").Value = iBreak
Do Until iBreak = 0
If Len(Trim(Left(strTemp, iBreak - 1))) > 0 Then
iRow = iRow + 1
Cells(iRow, 2) = Left(strTemp, iBreak - 1)
End If
strTemp = Mid(strTemp, iBreak + 1)
iBreak = InStr(strTemp, vbLf)
Loop
If Len(Trim(strTemp)) > 0 Then
iRow = iRow + 1
Cells(iRow, 2) = strTemp
End If
Next iPtr1
'column C loop
iRow = 0
For iPtr2 = 1 To Cells(Rows.Count, 3).End(xlUp).Row
strTemp = Cells(iPtr2, 3)
iBreak = InStr(strTemp, vbLf)
Do Until iBreak = 0
If Len(Trim(Left(strTemp, iBreak - 1))) > 0 Then
iRow = iRow + 1
Cells(iRow, 4) = Left(strTemp, iBreak - 1)
End If
strTemp = Mid(strTemp, iBreak + 1)
iBreak = InStr(strTemp, vbLf)
Loop
If Len(Trim(strTemp)) > 0 Then
iRow = iRow + 1
Cells(iRow, 4) = strTemp
End If
Next iPtr2
End Sub
source to share
There is a bit of code that I call "waterfall fill" that does just that. If you can create a range of cells to fill (i.e. Set rng_in
), it will do it. It works on any number of columns, which is a nice feature. You can honestly feed him a range A:D
and he will polish your gaps.
Sub FillValueDown()
Dim rng_in As Range
Set rng_in = Range("B:B")
On Error Resume Next
Dim rng_cell As Range
For Each rng_cell In rng_in.SpecialCells(xlCellTypeBlanks)
rng_cell = rng_cell.End(xlUp)
Next rng_cell
On Error GoTo 0
End Sub
Before and after shows that the code is being filled.
How it works
This code works by getting the range of all empty cells. By default SpecialCells
only scans UsedRange
because of quirk sxlCellTypeBlanks
. From there, it sets the value of the empty cell to be equal to the closest cell on top of it using End(xlUp)
. Error handling is in place because it xlCellTypeBlanks
will return an error if nothing is found. If you make an entire column with an empty row at the top (like an image), the error will never be thrown.
source to share