moving data from rows into columns for everySolved/Closed

Question

Hello,

I have data in a single column and would like to transpose it into a row for every three rows with a space delimiter, for example; The column of data varies in the amount of data each time.

A
B
C
D
E
F
G
H
I
J
etc

into

A B C
D E F
G H I
J etc

Thank you in advance for any advise or solution that will help me solve this issue.
Rick

mubashir aziz · Accepted Answer

Suppose your data is in A1:A50 or A500 ........ then a work sheet function approach is .... 

B2=OFFSET(A1,2*(ROW()-1),0)&" "&OFFSET(A1,2*(ROW()-1)+1,0)&" "&OFFSET(A1,2*(ROW()-1)+2,0)

and drag it down .....

venkat1926 · Answer

suppose the data are in A2 down with A1 having column headings.

try this macro 

the results will be in columns C to E

the macro is 
[code]
Sub test()
Dim rng As Range, m As Integer, c As Range
Columns("c:E").Delete
m = 3
Set rng = Range(Range("a2"), Range("a2").End(xlDown))
Set c = Range("a2")
Do While c <> ""
'MsgBox c.Address

Range(c, c.Offset(m - 1, 0)).Copy
Cells(Rows.Count, "c").End(xlUp).Offset(1, 0).PasteSpecial Transpose:=True
Set c = c.Offset(m, 0)
Loop


End Sub
/code

venkat1926 · Answer

I have added one row before the first us-united states in case the first  such string is not in row 2(row 1 is headings)
if the first string is in row 2 then also the macro will take care of it. 
As this changes your data in column A you copy the original data before running the macro into sheet 2
so that this can be retrieved. both sheet1 and sheet 2 are like this.

heading
2
US - UNITED STATES
3
5
US - UNITED STATES
36
US - UNITED STATES
35

try this macro and see sheet 1

POST CONFIRMATION WHETHER THE MACRO DOES WHAT YOU WANT 

The macro is 

Sub test()
Dim x As String, rfind As Range, add As String, y As String
Dim rprev As Range, j As Integer, k As Integer, m As Integer
undo
x = "US - UNITED STATES"
On Error Resume Next
Worksheets("sheet1").Activate
Set rfind = Cells.Find(what:=x, lookat:=xlPart)
add = rfind.Address
If rfind.Row = 2 Then
GoTo nnext
Else
k = 2
j = rfind.Row - 1
y = rfind
For m = k To j

y = y & "," & Cells(m, 1)
'msgbox y
If j = k Then GoTo outloop
Next m
outloop:
'msgbox y
rfind = y
End If
nnext:
Do

Set rfind = Cells.FindNext(after:=rfind)
If rfind Is Nothing Then Exit Do
If rfind.Address = add Then Exit Do
'msgbox rfind.Address

If Not rfind Is Nothing Then
Set rprev = Cells.FindPrevious(rfind)

j = rfind.Row
j = j - 1
k = rprev.Row
k = k + 1
y = rfind
'msgbox k
'msgbox j
For m = k To j

y = y & "," & Cells(m, 1)
'msgbox y
If j = k Then GoTo getout
Next m
getout:
'msgbox y
rfind = y
End If
Loop
End Sub
Sub undo()
Worksheets("sheet1").Cells.Clear
Worksheets("sheet2").UsedRange.Copy _
    Worksheets("sheet1").Range("A1")
End Sub

codenamered · Answer

I appreciate your help!  I apologize, I don't believe my question was very clear.  

I ran the macro and my data appeared, as such for column A (it is very close to what I need):
heading
2
US - UNITED STATES,2
3
5
US - UNITED STATES,3,5
36
US - UNITED STATES,36
35

Let me try to ask my question again.  My original data would appear like this:

column A

heading
US - UNITED STATES
3
5
US - UNITED STATES
36
US - UNITED STATES
35

And the result I wish to see is:

in column A:                   
row 1:   heading
row 2:   US - UNITED STATES          
row 3:   US - UNITED STATES         
row 4:   US - UNITED STATES         

and in column B:
row 1:
row 2:   3, 5
row 3:   36
row 4:   35

venkat1926 · Answer

try this modified macros.
even though all the three macros must be available in the standard module you have to run only the macro "test"
The macro "test" incorporates the other two modules. my version windows xp excel 2002

It is a good practice if the extract of data as you have done and also the result data are posted in the first thread, it would be helpful to help. It is also be good practice to post confirmation  if the solution helps. 

As I mentioned in the previous thread as you are messing up with the data, the data should be copied in sheet 2.
the macro "undo" (embedded in "test") will automatically clears sheet1 and copies original data from sheet 2.

the revised macros are 

Sub test()
Dim x As String, rfind As Range, add As String, y As String
Dim rprev As Range, j As Integer, k As Integer, m As Integer
undo
x = "US - UNITED STATES"
On Error Resume Next
Worksheets("sheet1").Activate
Set rfind = Cells.Find(what:=x, lookat:=xlPart)
add = rfind.Address
If rfind.Row = 2 Then
GoTo nnext
Else
k = 2
j = rfind.Row - 1
'y = rfind
For m = k To j

y = y & "," & Cells(m, 1)
'msgbox y
If j = k Then GoTo outloop
Next m
outloop:
'msgbox y
'msgbox Mid(y, 2, Len(y) - (k - 1))
rfind.Offset(0, 1) = Mid(y, 2, Len(y) - (k - 1))
End If
nnext:
Do

Set rfind = Cells.FindNext(after:=rfind)
If rfind Is Nothing Then Exit Do
If rfind.Address = add Then Exit Do
'msgbox rfind.Address

If Not rfind Is Nothing Then
Set rprev = Cells.FindPrevious(rfind)

j = rfind.Row
j = j - 1
k = rprev.Row
k = k + 1
y = ""
'msgbox k
'msgbox j
For m = k To j

y = y & "," & Cells(m, 1)
'msgbox y
If j = k Then GoTo getout
Next m
getout:
'msgbox y
'msgbox Mid(y, 2, (k - 1))
rfind.Offset(0, 1) = Mid(y, 2, (k - 1))
End If
Loop
sorting
End Sub
Sub undo()
Worksheets("sheet1").Cells.Clear
Worksheets("sheet2").UsedRange.Copy _
    Worksheets("sheet1").Range("A1")
End Sub
Sub sorting()
Dim j As Integer, k As Integer
Worksheets("sheet1").Activate
j = Cells(Rows.Count, "A").End(xlUp).Row
For k = j To 2 Step -1
If Cells(k, "B") = "" Then Cells(k, "B").EntireRow.Delete
Next
End Sub

venkat1926 · Answer

As the macros are few months old I have lost thread of the logic in the macros. I had to more or less re do it. any how I am giving the j macros as modified again. Remember main data is in first sheet 2. The macro first clears the sheet 1 and copies data in sheet 2 to sheet1 and manipulate sheet1.
perhaps the macros are clumsy and may be tweaked a lot. 
If it does the work it is ok. 
run only the macro "test" but all the macros should be  in the module.

Sub test()
Application.ScreenUpdating = False
Dim x As String, rfind As Range, add As String, y As String
Dim rprev As Range, j As Integer, k As Integer, m As Integer
undo
x = "US - UNITED STATES"
On Error Resume Next
Worksheets("sheet1").Activate
Set rfind = Cells.Find(what:=x, lookat:=xlPart)
add = rfind.Address
If rfind.Row = 2 Then
GoTo nnext
Else
k = 2
j = rfind.Row - 1
'y = rfind
For m = k To j

y = y & "," & " " & Cells(m, 1)
'msgbox y
If j = k Then GoTo outloop
Next m
outloop:
'msgbox y
'msgbox Mid(y, 2, Len(y) - (k - 1))
rfind.Offset(0, 1) = Mid(y, 2, Len(y) - (k - 1))
End If
nnext:
Do

Set rfind = Cells.FindNext(after:=rfind)
If rfind Is Nothing Then Exit Do
If rfind.Address = add Then
'Exit Do
j = Range("A1").End(xlDown).Row
Set rfind = Cells.FindPrevious(after:=Range("A" & j))
'MsgBox rfind.Address
k = rfind.Row + 1
GoTo line1
End If

'MsgBox rfind.Address

If Not rfind Is Nothing Then
Set rprev = Cells.FindPrevious(rfind)

j = rfind.Row
j = j - 1
k = rprev.Row
k = k + 1
'msgbox k
'msgbox j
line1:
For m = k To j

y = y & "," & " " & Cells(m, 1)
'msgbox y
If j = k Then GoTo getout
Next m
getout:

'msgbox y
'msgbox Mid(y, 2, (k - 1))
rprev.Offset(0, 1) = Mid(y, 3, Len(y) - 2)
End If
     If j = Range("A1").End(xlDown).Row Then
     Set rprev = Cells.FindPrevious(after:=Range("A" & j))
rprev.Offset(0, 1) = Mid(y, 3, Len(y) - 2)
GoTo line2
End If
y = ""
Loop
line2:
sorting
Application.ScreenUpdating = True
End Sub


Sub undo()
Worksheets("sheet1").Cells.Clear
Worksheets("sheet2").UsedRange.Copy _
    Worksheets("sheet1").Range("A1")
End Sub


Sub sorting()
Dim j As Integer, k As Integer
Worksheets("sheet1").Activate
j = Cells(Rows.Count, "A").End(xlUp).Row
For k = j To 2 Step -1
If Cells(k, "B") = "" Then Cells(k, "B").EntireRow.Delete
Next
End Sub

thomaswinter85 · Answer

thanks all..this helped me too.

Moving data from rows into columns for every

7 responses

Similar discussions

Subscribe To Our Newsletter!