Adjust code to run anywhere on sheet

[Howard]

This code works fine on a list with a Header in column A.
Copies the Header across the same row, starting 1 column to the right for as many columns as there are items in the list.
Cuts the items in the list to the right on a "slant" 1 column over and 1 row down until end of list.

So now the OP says the list will not always be in the same range but wants the code to do as it does here as I have posted. The lists to processed will be in different columns and not always starting at row 1.

I tried using 'For Each c In Selection' but I cannot figure out how to identify the header in the Selection to copy across as needed.

Thanks.
Howard

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

 

[Howard]

This code works fine on a list with a Header in column A.

Copies the Header across the same row, starting 1 column to the right for as many columns as there are items in the list.

Cuts the items in the list to the right on a "slant" 1 column over and 1 row down until end of list.



So now the OP says the list will not always be in the same range but wants the code to do as it does here as I have posted. The lists to processed will be in different columns and not always starting at row 1.



I tried using 'For Each c In Selection' but I cannot figure out how to identify the header in the Selection to copy across as needed.



Thanks.

Howard



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

Small correction:

<Copies the Header across the same row, starting 1 column to the right for as many columns as there are items in the list.>

Actually, if list starts in A1, then A1 is the anchor cell and all is displaced from A1. Put a few items in A1 to A5, run code will be a better explanation.

Howard

 

[joeu2004]

So now the OP says the list will not always be in the same
range but wants the code to do as it does here as I have
posted. The lists to processed will be in different columns
and not always starting at row 1.

I tried using 'For Each c In Selection' but I cannot figure
out how to identify the header in the Selection to copy across
as needed.

Minimally, try:

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.

Selection(1) is defensive programming: it ensures that sel references a
single cell (the header cell), even if the user selects multiple cells, even
a rectangular range.

However, that is inefficient because of the use of the clipboard. The
following runs 5.5 times faster on my computer (YMMV), if you can tolerate
the assumptions detailed below.

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

Further simplications and optimizations can be made, depending on additional
assumptions.

Assumptions:

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

This assumption is due to the use of Offset(2) instead of Offset(1) and i=1
instead of i=0.

If you do not want to make that assumption, some simple tweaks will make it
work. Let us know if you need help with that.

2. The header cell and subsequent cells can contain formulas or constant
values.

Further simplifications could be made if we one or both are not formulas.
But the changes would not improve the run time substantially.

However, if the cells contain formulas, their formats are not copied above.
That is one benefit of using the clipboard.


----- original message -----

 

[Howard]

Minimally, try:



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.



Selection(1) is defensive programming: it ensures that sel references a

single cell (the header cell), even if the user selects multiple cells, even

a rectangular range.



However, that is inefficient because of the use of the clipboard. The

following runs 5.5 times faster on my computer (YMMV), if you can tolerate

the assumptions detailed below.



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



Further simplications and optimizations can be made, depending on additional

assumptions.



Assumptions:



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



This assumption is due to the use of Offset(2) instead of Offset(1) and i=1

instead of i=0.



If you do not want to make that assumption, some simple tweaks will make it

work. Let us know if you need help with that.



2. The header cell and subsequent cells can contain formulas or constant

values.



Further simplifications could be made if we one or both are not formulas.

But the changes would not improve the run time substantially.



However, if the cells contain formulas, their formats are not copied above.

That is one benefit of using the clipboard.





----- original message -----

Thanks, Joeu,

Nice work! I believe all
assumptions are quite workable.

Thanks again and I will forward with a note of credit.

Regards,
Howard