In a sheet called "$2500-$4999" I have a range A1:P35 (16 rows). In columns O and P, there are two lines of text separated by a line break like this:
[TABLE="class: grid, width: 500, align: left"]
<tbody>[TR]
[TD]Column O[/TD]
[TD]Column P[/TD]
[/TR]
[TR]
[TD]Michael Smith
Matt Kennedy[/TD]
[TD]Vice President
President[/TD]
[/TR]
</tbody>[/TABLE]
I'm trying to come up with some VBA that will copy the entire row (A2:P2, for instance), insert a new row below, paste the text, and split the line breaks so one is now in each cell, like this:
[TABLE="class: grid, width: 500, align: left"]
<tbody>[TR]
[TD]Column O[/TD]
[TD]Column P[/TD]
[/TR]
[TR]
[TD]Michael Smith[/TD]
[TD]Vice President[/TD]
[/TR]
[TR]
[TD]Matt Kennedy[/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]
I'm working with the code at the bottom of this post, and am very close, but for some reason, everything works correctly, only Column O is not splitting correctly and looks like this:
[TABLE="class: grid, width: 500, align: left"]
<tbody>[TR]
[TD]Column O[/TD]
[TD]Column P[/TD]
[/TR]
[TR]
[TD]Michael Smith
Matt Kennedy (shouldn't appear here)[/TD]
[TD]Vice President[/TD]
[/TR]
[TR]
[TD]Michael Smith (shouldn't appear here)
Matt Kennedy[/TD]
[TD]President[/TD]
[/TR]
</tbody>[/TABLE]
Would I need to do two seperate VBA macros? I am not sure what is wrong with the code - any ideas?
Sub ExpandIfBreak()
Sheets("$2500-$4999").Select
Dim lR As Long, R As Range, i As Long, n As Long, j As Long, ct As Long, V As Variant
lR = Range("A" & Rows.Count).End(xlUp).Row
Set R = Range("A1:P35" & lR)
Application.ScreenUpdating = False
For i = R.Rows.Count To 1 Step -1
n = InStr(R.Rows(i).Cells(1, 7), Chr(10))
If n > 0 Then
ct = 0
For j = 1 To Len(R.Rows(i).Cells(1, 7))
If Mid(R.Rows(i).Cells(1, 7).Value, j, 1) = Chr(10) Then
ct = ct + 1
End If
Next j
j = 0
R.Rows(i).Offset(1, 0).Resize(ct).EntireRow.Insert
R.Rows(i).Resize(ct + 1).FillDown
V = Split(R.Rows(i).Cells(1, 7).Value, Chr(10))
For j = 0 To ct
R.Rows(i + j).Cells(1, 7).Value = V(j)
Next j
j = 0
End If
Next i
Sheets("Data").Select
End Sub
[TABLE="class: grid, width: 500, align: left"]
<tbody>[TR]
[TD]Column O[/TD]
[TD]Column P[/TD]
[/TR]
[TR]
[TD]Michael Smith
Matt Kennedy[/TD]
[TD]Vice President
President[/TD]
[/TR]
</tbody>[/TABLE]
I'm trying to come up with some VBA that will copy the entire row (A2:P2, for instance), insert a new row below, paste the text, and split the line breaks so one is now in each cell, like this:
[TABLE="class: grid, width: 500, align: left"]
<tbody>[TR]
[TD]Column O[/TD]
[TD]Column P[/TD]
[/TR]
[TR]
[TD]Michael Smith[/TD]
[TD]Vice President[/TD]
[/TR]
[TR]
[TD]Matt Kennedy[/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]
I'm working with the code at the bottom of this post, and am very close, but for some reason, everything works correctly, only Column O is not splitting correctly and looks like this:
[TABLE="class: grid, width: 500, align: left"]
<tbody>[TR]
[TD]Column O[/TD]
[TD]Column P[/TD]
[/TR]
[TR]
[TD]Michael Smith
Matt Kennedy (shouldn't appear here)[/TD]
[TD]Vice President[/TD]
[/TR]
[TR]
[TD]Michael Smith (shouldn't appear here)
Matt Kennedy[/TD]
[TD]President[/TD]
[/TR]
</tbody>[/TABLE]
Would I need to do two seperate VBA macros? I am not sure what is wrong with the code - any ideas?
Sub ExpandIfBreak()
Sheets("$2500-$4999").Select
Dim lR As Long, R As Range, i As Long, n As Long, j As Long, ct As Long, V As Variant
lR = Range("A" & Rows.Count).End(xlUp).Row
Set R = Range("A1:P35" & lR)
Application.ScreenUpdating = False
For i = R.Rows.Count To 1 Step -1
n = InStr(R.Rows(i).Cells(1, 7), Chr(10))
If n > 0 Then
ct = 0
For j = 1 To Len(R.Rows(i).Cells(1, 7))
If Mid(R.Rows(i).Cells(1, 7).Value, j, 1) = Chr(10) Then
ct = ct + 1
End If
Next j
j = 0
R.Rows(i).Offset(1, 0).Resize(ct).EntireRow.Insert
R.Rows(i).Resize(ct + 1).FillDown
V = Split(R.Rows(i).Cells(1, 7).Value, Chr(10))
For j = 0 To ct
R.Rows(i + j).Cells(1, 7).Value = V(j)
Next j
j = 0
End If
Next i
Sheets("Data").Select
End Sub
Last edited: