Solved: Text to Columns with an extra bit

Good afternoon all,

I'm sure I've seen this one the forum somewhere, but can I find it now, can I heck.

I have a column of data in the middle of a worksheet (lets say column G), that has numbers in it and some may be multiples seperated by a comma.

I want to copy columns G & H, splitting multiples in column G onto new rows where necessary, and having column H populate these new rows.

See attachment for example

[vba]

Sub Reformat()
Dim vec As Variant
Dim lastrow As Long
Dim i As Long

Application.ScreenUpdating = False

With ActiveSheet

lastrow = .Cells(.Rows.Count, "G").End(xlUp).Row
For i = lastrow To 2 Step -1

If .Cells(i, "G").Value <> "" Then

If InStr(.Cells(i, "G").Value, ",") > 0 Then

vec = Split(.Cells(i, "G").Value, ",")
.Rows(i + 1).Resize(UBound(vec) - LBound(vec)).Insert
.Cells(i, "G").Resize(UBound(vec) - LBound(vec) + 1) = Application.Transpose(vec)
.Cells(i, "H").Copy .Cells(i + 1, "H").Resize(UBound(vec) - LBound(vec))
End If
End If
Next i
End With

Application.ScreenUpdating = True
End Sub[/vba]

Thanks XLD,

I was surprised to see it could be done in situ, I thought it might have had to go on another sheet.

It is possible to amend slightly to copy B thru Q as well as splitting G and copying H

What happens in the other columns, is it a straight copy as per column H?

Sorry for the delay in responding XLD.

it is a straight copy of all columns except for the splitting of column G.

OK, this should do you

[vba]

Sub Reformat()
Dim vec As Variant
Dim lastrow As Long
Dim i As Long

Application.ScreenUpdating = False

With ActiveSheet

lastrow = .Cells(.Rows.Count, "G").End(xlUp).Row
For i = lastrow To 2 Step -1

If .Cells(i, "G").Value <> "" Then

If InStr(.Cells(i, "G").Value, ",") > 0 Then

vec = Split(.Cells(i, "G").Value, ",")
.Rows(i + 1).Resize(UBound(vec) - LBound(vec)).Insert
.Cells(i, "B").Resize(, 15).Copy .Cells(i + 1, "B").Resize(UBound(vec) - LBound(vec))
.Cells(i, "G").Resize(UBound(vec) - LBound(vec) + 1) = Application.Transpose(vec)
End If
End If
Next i
End With

Application.ScreenUpdating = True
End Sub[/vba]

Thanks XLD, that's brilliant (as usual)

thanks a lot
it also help me
:bow: