Solved: Move every Nth cell up without affecting the rest of the columns

[vanhunk]

Move every Nth cell up without affecting the rest of the columns.



Hi there,

I want to move the content of every Nth cell in a column up to just below the previous "N-cell" without affecting the rest of the columns.
In other words, in a specific column I want to keep for example every fourth entry, remove everything in between and move them up so that all the original fourth entry cell contents are now directly below each other, without affecting the other columns.
1a => 1a
2b => 2d
3c => 3g
4d => 4j
5e => 5
6f => 6
7g => 7
8h => 8
9i => 9
10j => 10

Thanks

[CodeNinja]

Try something like this:

Sub test()
Dim iNth As Integer
Dim str As String
Dim lRow As Long
Dim lCount As Long
Dim iCol As Integer
Dim rng As Range
Dim sCol As String

iCol = 2 'change this to adjust the column you wish to fix
sCol = "B" 'change this to match icol's letter
iNth = Application.InputBox(Prompt:="Please enter the number you wish to use", Type:=1)
lCount = 1

For lRow = 1 To Sheet1.Range(sCol & Sheet1.Rows.Count).End(xlUp).Row
str = Sheet1.Cells(1 + ((lRow - 1) * iNth), iCol)
Sheet1.Cells(lRow, iCol) = str
lCount = lCount + 1
Next lRow

Set rng = Sheet1.Range(sCol & lCount & ":" & sCol & Sheet1.Rows.Count)
rng.ClearContents



End Sub

[mikerickson]

I notice that in your example, you are keeping the value of every third cell.
Perhaps something likeDim FourthCellValues as Variant
Dim i As Long, Pointer As Long

With Sheet1.Range("A:A")
With Range(.Cells(1,1), .Cells(.Rows.Count, 1).End(xlup))
ReDim FourthCellValues(1 to .Rows.Count)
For i = 1 To .Rows.Count Step 3
Pointer = Pointer + 1
FourthCellValues(Pointer) = .Cells(i,1).Value
Next i
ReDim Preserve FourthCellValues(1 to Pointer)
.Clear.Contents
.Resize(Pointer, 1).Value = Application.Transpose(FourthCellValues)
End With
End With

[vanhunk]

Hi mikerickson,

Thank you for the reply. It works perfectly, except for the deleting bit. The code bombs out in the line .Clear.Contents with the message of "Object Required" - Error message 424.

Thanks

[vanhunk]

Thanks CodeNinja,

When I run the code it repeats the first row a number of times and deletes the rest.

[snb]

Sub snb()
sn = Cells(1).CurrentRegion.Columns(1)
ReDim sp(UBound(sn), 0)

For j = 1 To UBound(sn) Step 4
sp(j \ 4, 0) = sn(j, 1)
Next

Cells(1).CurrentRegion.Columns(1) = sp
End Sub

or

Sub snb_oneliner()
Cells(1).CurrentRegion.Columns(1) = Application.Index(Cells(1).CurrentRegion.Columns(1), [4*row(1:9)])
End Sub

[vanhunk]

Whoa! This is impressive. The one liner doesn't work that well. It skips the first value and the bottom rows of the resultant list contains "N/A"s.

In the first sub, how would you change it to work only on a selected portion of a column, in other words you would only like to manipulate the selected rows in a column.

Thanks again for the excellent reply.

[snb]

It skips the first value and the bottom rows of the resultant list contains "N/A"s.
Reply
Sub snb_twoliner()
With Cells(1).CurrentRegion.Columns(1)
.Value = Application.Index(.Value, [4*(row(1:9)-1)+1])
.SpecialCells(2, 16).ClearContents
End With
End Sub

[mikerickson]

To fix my code, remove the . in Clear.Contents

[vanhunk]

Hi mikerickson,

It is working beautifully, thanks.:beerchug: How would you change it to work on a selected portion of a column only? In other words the first cell of the selection stays in place and the rest of the selection is dealt with as above, while the rest of the column and other columns stay intact.:doh:

Thanks

[vanhunk]

Hi snb,

Thank you for all your effort - much appreciated. I love the conciseness of your code. Please could you explain what the following line means?
sp(j \ 4, 0) = sn(j, 1) Thanks

[vanhunk]

Hi snb,

One last question, I hope. How would you change it to work on a selected portion of a column only? In other words the first cell of the selection stays in place and the rest of the selection is dealt with as above, while the rest of the column and other columns stay intact.
Sub snb() sn = Cells(1).CurrentRegion.Columns(1) ReDim sp(UBound(sn), 0) For j = 1 To UBound(sn) Step 4 sp(j \ 4, 0) = sn(j, 1) Next Cells(1).CurrentRegion.Columns(1) = sp End Sub :doh:

[snb]

You could use:
Sub snb_threeliner()
With Selection
Cells(1, 27) = .Cells(1).Row
.Value = Application.Index(.Value, [4*(row(1:9)-1)+AA1])
.SpecialCells(2, 16).ClearContents
End With
End Sub