Multiple columns into rows

Closed
ybtronic Posts 1 Registration date Thursday June 17, 2010 Status Member Last seen June 17, 2010 - Jun 17, 2010 at 06:05 PM
rizvisa1 Posts 4479 Registration date Thursday January 28, 2010 Status Contributor Last seen May 5, 2022 - Jun 17, 2010 at 08:26 PM
Hello,

Can someone please give me some guidance on how I can do this?

Let say I have:

Sheet1 :

usergroup a
user xx1 xx2 xx3 xx4 xx5 xx6 xx7 xx8
usergroup b
user bb1 bb2 bb3 bb4 bb5

and I want it to be

Sheet2:



usergroup user
a xx1
a xx2
a xx3
a xx4
a xx5
a xx6
a xx7
a xx8
b bb1
b bb2
b bb3
b bb4
b bb5


Much and much appreciated if someone can help.

thank you
Vi

1 reply

rizvisa1 Posts 4479 Registration date Thursday January 28, 2010 Status Contributor Last seen May 5, 2022 768
Jun 17, 2010 at 08:26 PM
Try this
It is assuming that
the two sheets are called sheet1 and sheet2

sheet2 headers are already set

data is to be copied from sheet1 to sheet2


Sub ShiftAround()
Dim Cell As Range
Dim lSheet1Row As Long
Dim lSheet2Row As Long

Dim lRow As Long
Dim iCol As Integer

Set Cell = Cells.Find("*", Cells(1, 1), SearchOrder:=xlByRows, SearchDirection:=xlPrevious)

If Cell Is Nothing Then Exit Sub

lSheet1Row = Cell.Row

For lRow = 1 To lSheet1Row

Sheets("Sheet1").Select
' CHECK IF THE ROW IS ODD
If (lRow Mod 2 = 1) Then

sValue = Cells(lRow, "B")

'CHECK IF THE ROW IS NOT NULL (BY DEFAUL MUST BE ALSO EVEN)
ElseIf (Cells(lRow, "A") <> "") Then

iCol = Cells(lRow, Columns.Count).End(xlToLeft).Column
Range(Cells(lRow, 2), Cells(lRow, iCol)).Copy

Sheets("Sheet2").Select

lSheet2Row = Cells(Rows.Count, "A").End(xlUp).Row

lSheet2Row = lSheet2Row + 1

Range("B" & lSheet2Row).PasteSpecial Transpose:=True

Range("A" & lSheet2Row & ":A" & Cells(Rows.Count, "B").End(xlUp).Row).Value = sValue

End If

Next lRow

Set Cell = Nothing
End Sub
0