Need to split a cell into multiple rows

[andrew.m.brown]

I have an interesting issue. I'm working with a Lotus Notes Database
that I'm trying to extract data from. I'm using Crystal Reports and
NotesSQL to drop the necessary data to excel. The issue is that Lotus
stores multiple lines of data in one field, separated by a line break
(chr(10)). I would like to write a macro that could break the data in
this column out into separate rows whenever a line break is found. I
was then planning to use ASAP Utilities' fill blanks macro to populate
any empty cells.

I've tried to do this on my own based on what I've read in this forum,
but have not had much success. What I have so far is:

Public Sub separatecells()
Dim s As String, s1 As String, s2 As String
Dim iloc As Long
s = ActiveCell.Value
iloc = InStr(1, s, Chr(10), vbTextCompare)
If iloc <> 0 Then
s1 = Trim(Left(s, iloc - 2))
s2 = Trim(Right(s, Len(s) - iloc))
ActiveCell.Offset(0, 0) = s1
ActiveCell.Offset(1, 0).Select
Selection.EntireRow.Insert
ActiveCell.Offset(0, 0) = s2
Else
ActiveCell.Offset(0, 0).Value = s
End If
End Sub

This does not loop through the selected cells because I'm having
issues with my loop because of IF statement. I could provide a sample
file if someone would like to help but needs additional information.
Any assistance would be greatly appreciated!!!!

 

[Rick Rothstein \(MVP - VB\)]

Does this do what you want (it's still keyed off the ActiveCell)?

Public Sub SeparateIntoCells()
Dim X As Long
Dim CellText As String
Dim IndividualLines() As String
With ActiveCell
CellText = .Value
IndividualLines = Split(CellText, vbLf)
For X = 0 To UBound(IndividualLines)
.Offset(X, 0).Value = IndividualLines(X)
Next
End With
End Sub

Rick

 

[Bob Phillips]

Public Sub ProcessData()
Const TEST_COLUMN As String = "A" '<=== change to suit
Dim i As Long
Dim LastRow As Long
Dim Pos As Long

With Application

.ScreenUpdating = False
.Calculation = xlCalculationManual
End With

With ActiveSheet

LastRow = .Cells(.Rows.Count, TEST_COLUMN).End(xlUp).Row
For i = LastRow To 1 Step -1

Pos = InStr(1, .Cells(i, "A").Value, Chr(10), vbTextCompare)
If Pos > 0 Then

.Rows(i + 1).Insert
.Cells(i + 1, "A").Value = Right$(.Cells(i, "A").Value,
Len(.Cells(i, "A").Value) - Pos)
.Cells(i, "A").Value = Left$(.Cells(i, "A").Value, Pos - 1)
End If
Next i

End With

With Application

.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With

End Sub

--
HTH

Bob

(there's no email, no snail mail, but somewhere should be gmail in my addy)