rearrange multiple columns under one column

  • Thread starter Thread starter Ahmad
  • Start date Start date
A

Ahmad

Hi
I have columns
A B C
354398 354616 354388
354399 354617 354389
35484 354620 354630
35485 354621 354650
35486 354622
354876 354623
35489 354624
how I can arrange these columns under A column like this:
A
354398
354399
35484
35485
35486
354876
35489
354616
354617
354620
354621
354622
354623
354624
354388
354389
354630
354650

Thank you
 
The easiest way is to just select the cells in each column and then use
Edit|Cut. Then move to the bottom of column A and Edit|paste

Repeat for each column.
 
The easiest way is to just select the cells in each column and then use
Edit|Cut.  Then move to the bottom of column A and Edit|paste

Repeat for each column.
Click to expand...

Thank you Dave
I know this method you can use it with a small data but I have
thousands of data it is very hard and take many time, before many
years I have rearranged my data
using excel function but I cant remember which function I used.
 
If your example data is all you have then Dave's cut and paste is easiest
method.

If much more then maybe a macro?

Sub OneColumnV2()
''''''''''''''''''''''''''''''''''''''''''
'Macro to copy columns of variable length'
'into 1 continous column in a new sheet '
'Modified 17 FEb 2006 by Bernie Dietrick
''''''''''''''''''''''''''''''''''''''''''
Dim iLastcol As Long
Dim iLastRow As Long
Dim jLastrow As Long
Dim ColNdx As Long
Dim WS As Worksheet
Dim myRng As Range
Dim ExcludeBlanks As Boolean
Dim mycell As Range

ExcludeBlanks = (MsgBox("Exclude Blanks", vbYesNo) = vbYes)
Set WS = ActiveSheet
iLastcol = WS.Cells(1, WS.Columns.Count).End(xlToLeft).Column
On Error Resume Next

Application.DisplayAlerts = False
Worksheets("Alldata").Delete
Application.DisplayAlerts = True

Sheets.Add.Name = "Alldata"

For ColNdx = 1 To iLastcol

iLastRow = WS.Cells(WS.Rows.Count, ColNdx).End(xlUp).Row

Set myRng = WS.Range(WS.Cells(1, ColNdx), _
WS.Cells(iLastRow, ColNdx))

If ExcludeBlanks Then
For Each mycell In myRng
If mycell.Value <> "" Then
jLastrow = Sheets("Alldata").Cells(Rows.Count, 1) _
.End(xlUp).Row
mycell.Copy
Sheets("Alldata").Cells(jLastrow + 1, 1) _
.PasteSpecial xlPasteValues
End If
Next mycell
Else
myRng.Copy
jLastrow = Sheets("Alldata").Cells(Rows.Count, 1) _
.End(xlUp).Row
mycell.Copy
Sheets("Alldata").Cells(jLastrow + 1, 1) _
.PasteSpecial xlPasteValues
End If
Next

Sheets("Alldata").Rows("1:1").entirerow.Delete

WS.Activate
End Sub


Gord Dibben MS Excel MVP
 
I don't know of a function that would do this. But you could use a macro:

Option Explicit
Sub testme()

Dim FirstCol As Long
Dim LastCol As Long
Dim iCol As Long
Dim DestCell As Range
Dim RngToCopy As Range

Dim wks As Worksheet

Set wks = ActiveSheet

With wks
FirstCol = 2 'don't touch column A
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column

For iCol = FirstCol To LastCol
Set RngToCopy = .Range(.Cells(1, iCol), _
.Cells(.Rows.Count, iCol).End(xlUp))

Set DestCell = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0)

RngToCopy.Copy _
Destination:=DestCell
Next iCol

'clean up those columns 2:xxxx
.Cells(1, FirstCol).Resize(1, LastCol - FirstCol + 1) _
.EntireColumn.Delete
End With

End Sub

If you're new to macros:

Debra Dalgleish has some notes how to implement macros here:
http://www.contextures.com/xlvba01.html

David McRitchie has an intro to macros:
http://www.mvps.org/dmcritchie/excel/getstarted.htm

Ron de Bruin's intro to macros:
http://www.rondebruin.nl/code.htm

(General, Regular and Standard modules all describe the same thing.)
 
I don't know of a function that would do this.  But you could use a macro:

Option Explicit
Sub testme()

    Dim FirstCol As Long
    Dim LastCol As Long
    Dim iCol As Long
    Dim DestCell As Range
    Dim RngToCopy As Range

    Dim wks As Worksheet

    Set wks = ActiveSheet

    With wks
        FirstCol = 2 'don't touch column A
        LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column

        For iCol = FirstCol To LastCol
            Set RngToCopy = .Range(.Cells(1, iCol), _
                                       .Cells(.Rows.Count, iCol).End(xlUp))

            Set DestCell = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0)

            RngToCopy.Copy _
                Destination:=DestCell
        Next iCol

        'clean up those columns 2:xxxx
        .Cells(1, FirstCol).Resize(1, LastCol - FirstCol + 1) _
              .EntireColumn.Delete
    End With            

End Sub

If you're new to macros:

Debra Dalgleish has some notes how to implement macros here:http://www.contextures.com/xlvba01.html

David McRitchie has an intro to macros:http://www.mvps.org/dmcritchie/excel/getstarted.htm

Ron de Bruin's intro to macros:http://www.rondebruin.nl/code.htm

(General, Regular and Standard modules all describe the same thing.)
Click to expand...

Dear Gord and Dave
firstly thank you for replays I think my question was wrong I want to
rearrange my data from rows to one column starting from the first row
then second row please lock to my example,
her I want to transpose my rows in one column.


Orignal Data
A B C D
22 34 12 56
44 23 23 32
45 23 78 45
56 45 33 24

Rearranged to this form

22
34
12
56
44
23
23
32
45
23
78
45
56
45
33
24
 
Dear Gord and Dave
firstly thank you for replays I think my question was wrong I want to
rearrange my data from rows to one column starting from the first row
then second row please lock to my example,
her I want to transpose my rows in one column.

Orignal Data
A       B       C       D
22      34      12      56
44      23      23      32
45      23      78      45
56      45      33      24

Rearranged to this form

22
34
12
56
44
23
23
32
45
23
78
45
56
45
33
24
Click to expand...

I think offset function is suitable for this data but how i can use
it.
 
Sub rowstocol()

Dim wks As Worksheet
Dim colnos As Long
Dim CopytoSheet As Worksheet

If ActiveSheet.Name = "Copyto" Then
MsgBox "Active Sheet Not Valid" & Chr(13) _
& "Try Another Worksheet."
Exit Sub
Else
Set wks = ActiveSheet
Application.ScreenUpdating = False
For Each Wksht In Worksheets
With Wksht
If .Name = "Copyto" Then
Application.DisplayAlerts = False
Sheets("Copyto").Delete
End If
End With
Next
Application.DisplayAlerts = True
Set CopytoSheet = Worksheets.Add
CopytoSheet.Name = "Copyto"
wks.Activate
Range("A1").Select
colnos = InputBox("Enter Number of Columns to Transpose to Rows")

Do Until ActiveCell.Value = ""
ActiveCell.Offset(1, 0).Select
With ActiveCell
.Resize(1, colnos).Copy
End With
Sheets("Copyto").Select
Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, _
SkipBlanks:=False _
, Transpose:=True
Application.CutCopyMode = False
ActiveSheet.Cells(Rows.Count, ActiveCell.Column).End(xlUp).Select
ActiveCell.Offset(2, 0).Select
Selection.EntireRow.Insert
wks.Activate
ActiveCell.Select
Loop
Sheets("Copyto").Activate
End If
End Sub


Gord
 
Sub rowstocol()

    Dim wks As Worksheet
    Dim colnos As Long
    Dim CopytoSheet As Worksheet

    If ActiveSheet.Name = "Copyto" Then
        MsgBox "Active Sheet Not Valid" & Chr(13) _
               & "Try Another Worksheet."
        Exit Sub
    Else
        Set wks = ActiveSheet
        Application.ScreenUpdating = False
        For Each Wksht In Worksheets
            With Wksht
                If .Name = "Copyto" Then
                    Application.DisplayAlerts = False
                    Sheets("Copyto").Delete
                End If
            End With
        Next
        Application.DisplayAlerts = True
        Set CopytoSheet = Worksheets.Add
        CopytoSheet.Name = "Copyto"
        wks.Activate
        Range("A1").Select
        colnos = InputBox("Enter Number of Columns to Transposeto Rows")

        Do Until ActiveCell.Value = ""
            ActiveCell.Offset(1, 0).Select
            With ActiveCell
                .Resize(1, colnos).Copy
            End With
            Sheets("Copyto").Select
            Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, _
                                   SkipBlanks:=False _
                                               , Transpose:=True
           Application.CutCopyMode = False
           ActiveSheet.Cells(Rows.Count, ActiveCell.Column).End(xlUp).Select
            ActiveCell.Offset(2, 0).Select
            Selection.EntireRow.Insert
            wks.Activate
            ActiveCell.Select
        Loop
        Sheets("Copyto").Activate
    End If
End Sub

Gord
Click to expand...

Dear Gord
Thank you very much for your macro, now I can handle my data but in
new column there are one cell blank between every row how can i delete
this row using your macro.
best regards
Dr: Ahmad Dahamsheh
 
Sorry about that blank row. Forgot what I was doing.

Revised code to omit blank rows. Edit your code as below where noted

Application.CutCopyMode = False
ActiveSheet.Cells(Rows.Count, ActiveCell.Column).End(xlUp).Select
ActiveCell.Offset(1, 0).Select 'note: changed from 2 to 1
' Selection.EntireRow.Insert 'note: I have remmed out this line
wks.Activate
ActiveCell.Select
Loop


Gord
 
Another one:

Option Explicit
Sub testme()

Dim FirstCol As Long
Dim LastCol As Long
Dim iRow As Long
Dim FirstRow As Long
Dim LastRow As Long

Dim DestCell As Range
Dim RngToCopy As Range

Dim wks As Worksheet

Set wks = ActiveSheet

Set DestCell = Worksheets.Add().Range("A1")

With wks
FirstCol = 1
FirstRow = 1
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

For iRow = FirstRow To LastRow
LastCol = .Cells(iRow, .Columns.Count).End(xlToLeft).Column
Set RngToCopy = .Range(.Cells(iRow, FirstCol), _
.Cells(iRow, .Columns.Count).End(xlToLeft))

RngToCopy.Copy
DestCell.PasteSpecial Transpose:=True

Set DestCell = DestCell.Offset(RngToCopy.Columns.Count)
Next iRow
End With

End Sub
 
Another one:

Option Explicit
Sub testme()

    Dim FirstCol As Long
    Dim LastCol As Long
    Dim iRow As Long
    Dim FirstRow As Long
    Dim LastRow As Long

    Dim DestCell As Range
    Dim RngToCopy As Range

    Dim wks As Worksheet

    Set wks = ActiveSheet

    Set DestCell = Worksheets.Add().Range("A1")

    With wks
        FirstCol = 1
        FirstRow = 1
        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

        For iRow = FirstRow To LastRow
            LastCol = .Cells(iRow, .Columns.Count).End(xlToLeft).Column
            Set RngToCopy = .Range(.Cells(iRow, FirstCol), _
                                .Cells(iRow, .Columns.Count).End(xlToLeft))

            RngToCopy.Copy
            DestCell.PasteSpecial Transpose:=True

            Set DestCell = DestCell.Offset(RngToCopy.Columns.Count)
        Next iRow
    End With

End Sub
Click to expand...

Dear Dave And Gord
Thank you for your help, your macros are work perfectly.

with my best regards

Dr:Ahmad Dahamsheh
 
Back
Top