PDA

View Full Version : Solved: Text to Columns with an extra bit



MRichmond
02-17-2012, 07:06 AM
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

xld
02-17-2012, 07:37 AM
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

MRichmond
02-17-2012, 07:57 AM
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

xld
02-17-2012, 09:21 AM
What happens in the other columns, is it a straight copy as per column H?

MRichmond
02-20-2012, 12:12 AM
Sorry for the delay in responding XLD.

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

xld
02-20-2012, 03:07 AM
OK, this should do you



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

MRichmond
02-20-2012, 03:25 AM
Thanks XLD, that's brilliant (as usual)

wakdafak
02-23-2012, 12:04 AM
thanks a lot
it also help me
:bow: