MACRO to copy and transpose data in a column

[bh9aq]

Hi there,

Im trying to create a Macro which can do the following: Go to the selected cell when Macro is run, keep going down cell by cell until it finds a blank cell, select the values, copy them and paste them by transposing into the cell next to where it started from in a row, carry on doing this procedure and pasting the transposed values next to the first non blank value until it gets to the end of this column. Can you please help me with this Macro. Help will be greatly appreciated.

Regards

 

[Weaver]

If I understand you correctly, try this:

Sub test()
    lr = Cells(Rows.Count, Selection.Column).End(xlUp).Row
    fr = ActiveCell.Row
    c = ActiveCell.Column
    For i = fr To lr
        Range(Cells(i, c), Cells(lr, c)).Copy
        Cells(i, c + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
    Next i
End Sub

 

[bh9aq]

Thanks for your response. Let me try to explain that again. I have values in a column as below:
1
2
3
5
6

8
7
4
9

4
3

etc. so after a set of numbers I have blank cells. what I want the Macro to do is to start at the first value, keep coming down until it finds the blank cell which is after 6, now copy from 1-6 and paste it in the next column as a row i-e transpose values from 1-6 and paste them next to value 1 then keep going down after the blank cell, come to value 8 and keep going down until the next blank is found which is after the value 9, copy values from 8-9 and paste them in a row next to 8....carry on this process until the values end in that column. The above code pastes the values in columns and keeps cascading in next columns until its only showing one value in the last column if you know what I mean

Thanks for your help.

 

[Weaver]

I think this ought to do it

Sub test2()
    Dim t As Range, u As Range
    c = ActiveCell.Column
    fr = ActiveCell.Row
    lr = Cells(Rows.Count, c).End(xlUp).Row
    r = fr
    Do
        Set t = Cells(r, c)
        Set u = t.End(xlDown)
        Range(t, u).Copy
        t.Offset(, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
        r = u.End(xlDown).Row
    Loop While r < lr
    Application.CutCopyMode = False
End Sub

 

[bh9aq]

Thank you very much...its greatly appreciated.

You've made me save a lot of my time.

Thanks

 

[cam112]

I think this ought to do it

Sub test2()
    Dim t As Range, u As Range
    c = ActiveCell.Column
    fr = ActiveCell.Row
    lr = Cells(Rows.Count, c).End(xlUp).Row
    r = fr
    Do
        Set t = Cells(r, c)
        Set u = t.End(xlDown)
        Range(t, u).Copy
        t.Offset(, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
        r = u.End(xlDown).Row
    Loop While r < lr
    Application.CutCopyMode = False
End Sub

Thanks so much for your code. It is exactly what I am looking for. But would you mind to suggest a modification to make it paste to the next row instead of the first row of each set of records?

i.e.

1 12356
2 8749
3 43
5
6


8
7
4
9


4
3

Thanks a lot!