Moving each subsequent row over one column

LAAdams17

Board Regular
Joined
Oct 23, 2009
Messages
73
I would like to take a column of data (numbers or text) so I can use it for an Advanced Search Criteria and change it from:

ID#
264
372
521
601
784

<tbody>
</tbody>


to . . .

ID#ID#ID#ID#ID#
264
372
521
601
784

<tbody>
</tbody>
 

Excel Facts

How to show all formulas in Excel?
Press Ctrl+` to show all formulas. Press it again to toggle back to numbers. The grave accent is often under the tilde on US keyboards.
How about:

Code:
Sub moveThem()
For i = 3 To 6
Range("A" & i & ":" & Chr(i + 62) & i).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Next
End Sub
 
Upvote 0
That's very helpful; thank you.

Do know how to do this based on the current selection regardless of the location in the spreadsheet or the number of cells selected (in this example there were 6 including the header row, but there may be 10 or 50 or ???)? One other thing I'm looking to automate (but it's not nearly as important as the above) is to extend the header/title (in the original example, "ID#") across the number of columns based on the number of rows selected (as illustrated in the original example).

Again, many thanks!
 
Upvote 0
Say a column has values. Hi-light that part of the column you want to extend out and run this:

Code:
Sub moveThem2()
Dim r As Range, i As Long, j As Long
i = 1
For Each r In Selection
    For j = 1 To i
        r.Insert shift:=xlToRight
    Next j
    i = i + 1
Next r
End Sub
 
Upvote 0
Here is another way to do it...
Code:
Sub MoveValuesToDiagonal()
  Dim Cell As Range
  For Each Cell In Selection
    Cell.Cut Cell.Offset(, Cell.Row - Selection(1).Row)
  Next
End Sub
 
Upvote 0
Try any or all of these, I believe they do what you want.

Regards,
Howard

Code cLant is my attempt, but is hard coded to a specific column.
Code cLantx & cLantxx are my attempts tweeked by Joeu2004.

Code:
Option Explicit

Sub cLant()
Dim c As Range
Dim i As Long
Dim rCt As Range
Set rCt = Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)
i = 0
  For Each c In rCt
    c.Cut c.Offset(, i)
    Range("A1").Copy Range("A1").Offset(, i)
    i = i + 1
  Next
  
End Sub

'Following Tweeked by Joeu2004

Sub cLant() 
Dim c As Range 
Dim i As Long 
Dim rCt As Range, sel As Range 

Set sel = Selection(1) 
Set rCt = Range(sel.Offset(1), Cells(Rows.Count, sel.Column).End(xlUp)) 
i = 0 
For Each c In rCt 

    c.Cut c.Offset(0, i) 
    sel.Copy sel.Offset(0, i) 
    i = i + 1 
Next 
End Sub 


'That assumes the user selects at least the header cell. 

Sub cLant() 
Dim c As Range 
Dim i As Long 

Dim rCt As Range, sel As Range 
Dim h As Variant 

Set sel = Selection(1) 
Set rCt = Range(sel.Offset(2), Cells(Rows.Count, sel.Column).End(xlUp)) 
i = 1 
h = sel.Formula 
For Each c In rCt 

    c.Offset(0, i).Formula = c.Formula 
    c.Clear 
    sel.Offset(0, i).Formula = h 
    i = i + 1 
Next 
End Sub 



Assumptions: 

1. There are at least 2 cells under the header to be moved across. 

2. The header cell and subsequent cells can contain formulas or constant 
values.
 
Upvote 0
Rick, I really appreciate your code; it works perfectly. One other part I was looking to automate (but it's not nearly as important as the above) is to extend the header/title ("ID#" as illustrated in the example of the original post) across the number of columns based on the number of rows selected. Thank you again!
 
Upvote 0
Rick, I really appreciate your code; it works perfectly. One other part I was looking to automate (but it's not nearly as important as the above) is to extend the header/title ("ID#" as illustrated in the example of the original post) across the number of columns based on the number of rows selected. Thank you again!
I had figured since the selection could be arbitrary, that there would be no header.

Anyway, assuming the header cell is not part of the selection, we just need to add the line of code delineated in red...
Rich (BB code):
Sub MoveValuesToDiagonal()
  Dim Cell As Range
  Selection(1).Offset(-1).Resize(, Selection.Count).Value = Selection(1).Offset(-1).Value
  For Each Cell In Selection
    Cell.Cut Cell.Offset(, Cell.Row - Selection(1).Row)
  Next
End Sub
If the header will be part of the selection, then use this modified code instead...
Rich (BB code):
Sub MoveValuesToDiagonal()
  Dim Cell As Range
  Selection(1).Resize(, Selection.Count).Value = Selection(1).Value
  For Each Cell In Selection(1).Offset(1).Resize(Selection.Count - 1)
    Cell.Cut Cell.Offset(, Cell.Row - Selection(1).Offset(1).Row + 1)
  Next
End Sub
 
Last edited:
Upvote 0

Forum statistics

Threads
1,213,546
Messages
6,114,256
Members
448,558
Latest member
aivin

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top