cycle through a range copying and pasting vba

[danno79]

I have the following code which takes a source range (containing text and numbers) and cycles through it copying and pasting into the next column and moving the values down one row each time, the values that drop off the bottom are placed at the top of the newly pasted range ie

aaa1
aaa2
aaa3
aaa4
bbb1
bbb2
ccc1
ccc2

becomes

ccc2
aaa1
aaa2
aaa3
aaa4
bbb1
bbb2
ccc1

etc

This works well but I am trying to tweek it to skip a column each time, (ie a blank column between, the pasted ranges) but can only succeed in getting it to skip a column after the first. Any suggestions?

Sub Populate()
    
    Dim oRange1 As Range
    Dim startColumn1 As String
    Dim rangeStart1 As Integer
    Dim rangeEnd1 As Integer
    Dim cellCount1 As Integer
    Dim i1 As Integer

    startColumn1 = "B"
    rangeStart1 = 4
    rangeEnd1 = 11
    cellCount1 = rangeEnd1 - rangeStart1 + 1

    For i1 = 1 To cellCount1 - 1
        Set oRange1 = Worksheets("PROGRAM GRID").Range(startColumn1 & rangeStart1 & _
                                ":" & startColumn1 & (rangeEnd1 - i1))
        oRange1.Copy
        oRange1.Offset(i1, i1).PasteSpecial xlPasteAll

        Set oRange1 = Worksheets("PROGRAM GRID").Range(startColumn1 & (rangeEnd1 - i1 + 1) & _
                                ":" & startColumn1 & rangeEnd1)
        oRange1.Copy
        oRange1.Offset((-1 * cellCount1) + i1, i1).PasteSpecial xlPasteAll
    Next i1

End Sub

 

[MickG]

Hi, You could perhaps try this as an alternative.
NB:- Change Range(Rng) to suit.

[COLOR=navy]Sub[/COLOR] MG01Dec24
[COLOR=navy]Dim[/COLOR] Rng [COLOR=navy]As[/COLOR] Range, ray, col [COLOR=navy]As[/COLOR] [COLOR=navy]Integer[/COLOR]
[COLOR=navy]Set[/COLOR] Rng = Range(Range("A9"), Range("A" & Rows.Count).End(xlUp))
ray = Rng
    [COLOR=navy]For[/COLOR] col = 1 To 12 [COLOR=navy]Step[/COLOR] 2
        col = IIf(col = 1, 2, col)
        Cells(Rng(1).Row, 1).Offset(, col) = ray(UBound(ray), 1)
        ray(UBound(ray), 1) = ""
        Rng.Offset(1, col) = ray
        ray = Rng.Offset(, col).Resize(UBound(ray))
    [COLOR=navy]Next[/COLOR] col
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]

Regards Mick

 

[GTO]

Hi there,

If I am understanding correctly that you want a blank column between each column of 're-sorted' data, maybe:

<font face=Courier New><SPAN style="color:#00007F">Sub</SPAN> exa()<br>Dim _<br>aryOrigData     <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Variant</SPAN>, _<br>arySorted       <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Variant</SPAN>, _<br>aryExpanded     <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Variant</SPAN>, _<br>temp            <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Variant</SPAN>, _<br>x               <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>, _<br>y               <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN><br><br>    aryOrigData = Range("B4:B11").Value<br><br>    <SPAN style="color:#00007F">ReDim</SPAN> arySorted(1 <SPAN style="color:#00007F">To</SPAN> <SPAN style="color:#00007F">UBound</SPAN>(aryOrigData), 1 <SPAN style="color:#00007F">To</SPAN> <SPAN style="color:#00007F">UBound</SPAN>(aryOrigData))<br>    <SPAN style="color:#00007F">For</SPAN> x = 1 <SPAN style="color:#00007F">To</SPAN> <SPAN style="color:#00007F">UBound</SPAN>(arySorted, 1)<br>        arySorted(x, 1) = aryOrigData(x, 1)<br>    <SPAN style="color:#00007F">Next</SPAN><br>    <SPAN style="color:#00007F">For</SPAN> y = <SPAN style="color:#00007F">LBound</SPAN>(arySorted, 2) + 1 <SPAN style="color:#00007F">To</SPAN> <SPAN style="color:#00007F">UBound</SPAN>(arySorted, 2)<br>        temp = arySorted(UBound(arySorted, 1), y - 1)<br>        <SPAN style="color:#00007F">For</SPAN> x = <SPAN style="color:#00007F">UBound</SPAN>(arySorted, 1) - 1 <SPAN style="color:#00007F">To</SPAN> 1 <SPAN style="color:#00007F">Step</SPAN> -1<br>            arySorted(x + 1, y) = arySorted(x, y - 1)<br>        <SPAN style="color:#00007F">Next</SPAN> x<br>        arySorted(LBound(arySorted, 1), y) = temp<br><br>    <SPAN style="color:#00007F">Next</SPAN><br>    <br>    <SPAN style="color:#00007F">ReDim</SPAN> aryExpanded(1 <SPAN style="color:#00007F">To</SPAN> <SPAN style="color:#00007F">UBound</SPAN>(arySorted, 1), 1 <SPAN style="color:#00007F">To</SPAN> <SPAN style="color:#00007F">UBound</SPAN>(arySorted, 2) * 2)<br>    <SPAN style="color:#00007F">For</SPAN> y = 1 <SPAN style="color:#00007F">To</SPAN> <SPAN style="color:#00007F">UBound</SPAN>(arySorted, 2)<br>        <SPAN style="color:#00007F">For</SPAN> x = 1 <SPAN style="color:#00007F">To</SPAN> <SPAN style="color:#00007F">UBound</SPAN>(arySorted, 1)<br>            aryExpanded(x, (y * 2) - 1) = arySorted(x, y)<br>        <SPAN style="color:#00007F">Next</SPAN><br>    <SPAN style="color:#00007F">Next</SPAN><br>    Range("B4").Resize(UBound(aryExpanded, 1), UBound(aryExpanded, 2)).Value = aryExpanded<br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN></FONT>

Hope that helps,

Mark

 

[MickG]

Hi, Slight mod required , Change similar line to this:-

        Cells(Rng(1).Row, Rng.Column).Offset(, col) = ray(UBound(ray), 1)

NB:- Its best to specify the range (Rng) Explicitly, else there could be conflicts.
Regards Mick

 

[pgc01]

Hi

Another option:

Sub Populate()
    Dim rSource As Range
    Dim i1 As Long
 
    Set rSource = Worksheets("PROGRAM GRID").Range("B4:B11")
    With rSource
        For i1 = 1 To .Count - 1
            .Offset(i1, 0).Resize(.Count - i1).Copy .Item(1, 2 * i1 + 1)
            .Resize(i1).Copy .Item(.Count - i1 + 1, 2 * i1 + 1)
        Next i1
    End With
End Sub

 

[danno79]

Gentlemen - Thanks for your suggestions on this and sorry for the delay in posting a reply - power out for the latter part of yesterday afternoon, thats what you get for working out in the sticks!

Mark, Mick both your soultions work very well and avoid the obvious speed issues with copy and paste but i need to retain the background colours and formats from the original source range - any suggestions?

PGC - Retains the formatting form the original range but cycles through the source range in the opposite direction to what i need to achieve - can you suggest a way to do this in reverse?

Your guidance is greatly apprecited!

 

[pgc01]

PGC - Retains the formatting form the original range but cycles through the source range in the opposite direction to what i need to achieve - can you suggest a way to do this in reverse?

Ooops! You're right.

Try:

Sub Populate()
    Dim rSource As Range
    Dim i1 As Long
 
    Set rSource = Worksheets("PROGRAM GRID").Range("B4:B11")
    With rSource
        For i1 = 1 To .Count - 1
            .Offset(.Count - i1, 0).Resize(i1).Copy .Item(1, 2 * i1 + 1)
            .Resize(.Count - i1).Copy .Item(i1 + 1, 2 * i1 + 1)
        Next i1
    End With
End Sub

 

[danno79]

Spot on thanks