dividing contents from Column A and distribute to all columns evenly?

[suicidalporcupine]

If I have a set of numbers on Column A and I want to distribute it to B C and D evenly. but they must be in orders?

Column A	Column B	C	D
504	504	604	704
505	505	605	705
506	506	606	802
604
605
606
704
705
802

<tbody>
</tbody>

 

[suicidalporcupine]

I'm sorry, I don't understand your sheet, perhaps some more explanation and an before and after example. !!!

Thank you for being patient with me, i'm sorry for not explaining very clearly.

https://docs.google.com/spreadsheets/d/14Gu3xR4UTO50pby-kL7Uhztkj9vXfb0klVoT8yPK3iI/edit?usp=sharing

 

[Snakehips]

Mick & SP
I was originally looking to provide a formula solution, without helpers, and was all getting a bit ugly, even before the introduction of several source lists.
Mick, by providing the original vba solution, thankfully, you put me out of my misery.

Mick, I hope you don't mind me offering this modified version as a solution to the revised data setup?

It assumes that columns G:K hold the lists and that cell values are all constants.
There is an option to switch a couple of lines if it is preferred that the list area be selected rather than coded.

It matters not whether the source lists are ordered or not.

Sub MG14May39V2()
Dim Rng As Range, Dn As Range, Rws As Long, R As Variant, Ac As Long, k As Long


Application.ScreenUpdating = False
Range("B2:D" & Range("B" & Rows.Count).End(xlUp).Row).ClearContents
LR = ActiveSheet.UsedRange.Rows.Count
Set Rng = Range(Range("G2"), Range("K" & LR))
'*****
'or substitute line above with line below to work with selected score range*
'Set Rng = Selection  'remove leading apostrophe *
'*****
Qty = WorksheetFunction.CountA(Rng)
Rws = IIf(Qty / 3 = Int(Qty / 3), Qty / 3, Int(Qty / 3 + 1))


Select Case Qty Mod 3
    Case 1: R = Array(Rws, Rws - 1, Rws - 1)
    Case 2: R = Array(Rws, Rws, Rws - 1)
    Case 0: R = Array(Rws, Rws, Rws)
End Select


k = 1
For Ac = 0 To 2
    For Rw = 2 To R(Ac) + 1
    Cells(Rw, Ac + 2).Value = WorksheetFunction.Small(Rng, k)
    k = k + 1
    Next Rw
Next Ac
End Sub

 

[suicidalporcupine]

thank you

 

[suicidalporcupine]

Dim Rng As Range, Dn As Range, Rws As Long, R As Variant, Ac As Long, c As LongSet Rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
Rws = IIf(Rng.Count / 3 = Int(Rng.Count / 3), Rng.Count / 3, Int(Rng.Count / 3 + 1))
Rng.Offset(, 1).Resize(, 3).ClearContents

Select Case Rng.Count Mod 3
Case 1: R = Array(Rws, Rws - 1, Rws - 1)
Case 2: R = Array(Rws, Rws, Rws - 1)
Case 0: R = Array(Rws, Rws, Rws)
End Select

For Ac = 0 To 2
Cells(2, Ac + 2).Resize(R(Ac)).Value = Rng(1).Offset(c).Resize(R(Ac)).Value
c = c + R(Ac)
Next Ac
End Sub

So if I another list of numbers I need to distribute. and I wish to keep the 2nd list on the bottom of the first list

Can I just copy the same script and just modify the location?
How/where to modify the script so that the result will be on "B20:D20" rather than on B2:D2. The Range is still A2


Thank you

 

[PSBoyce]

Try this:-
Actual Data Start "A2", Results Start "B2".

[COLOR=Navy]Sub[/COLOR] MG14May39
[COLOR=Navy]Dim[/COLOR] Rng [COLOR=Navy]As[/COLOR] Range, Dn [COLOR=Navy]As[/COLOR] Range, Rws [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long,[/COLOR] R [COLOR=Navy]As[/COLOR] Variant, Ac [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long,[/COLOR] c [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long[/COLOR]
[COLOR=Navy]Set[/COLOR] Rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
Rws = IIf(Rng.Count / 3 = Int(Rng.Count / 3), Rng.Count / 3, Int(Rng.Count / 3 + 1))
Rng.Offset(, 1).Resize(, 3).ClearContents


[COLOR=Navy]Select[/COLOR] [COLOR=Navy]Case[/COLOR] Rng.Count Mod 3
    [COLOR=Navy]Case[/COLOR] 1: R = Array(Rws, Rws - 1, Rws - 1)
    [COLOR=Navy]Case[/COLOR] 2: R = Array(Rws, Rws, Rws - 1)
    [COLOR=Navy]Case[/COLOR] 0: R = Array(Rws, Rws, Rws)
[COLOR=Navy]End[/COLOR] Select


[COLOR=Navy]For[/COLOR] Ac = 0 To 2
    Cells(2, Ac + 2).Resize(R(Ac)).Value = Rng(1).Offset(c).Resize(R(Ac)).Value
    c = c + R(Ac)
[COLOR=Navy]Next[/COLOR] Ac
[COLOR=Navy]End[/COLOR] [COLOR=Navy]Sub[/COLOR]

Regards Mick

This is working PERFECTLY for what I need - However I need to be able to chance this from spreading out to three colums, to fourteen colums. I am losing my mind figuring out how to manipulate the code to work for 14 colums instead of 3.

Any pointers would be HUGELY appreciated.

Thank you in advance
Paul

 

[Eric W]

Welcome to the Board!

See if this works for you:

Sub SplitColumn()
Dim NumCols As Long, TopCell As Range, ResCell As Range, lr As Long
Dim r As Long, i As Long, n As Long

    NumCols = 14
    Set TopCell = Range("A2")
    Set ResCell = Range("C2")
    
    lr = Cells(Rows.Count, TopCell.Column).End(xlUp).Row - TopCell.Row + 1
    
    r = 0
    For i = 1 To NumCols
        n = lr \ NumCols + IIf(i <= lr Mod NumCols, 1, 0)
        ResCell.Offset(0, i - 1).Resize(n).Value = TopCell.Offset(r, 0).Resize(n).Value
        r = r + n
    Next i
    
End Sub

Change the values in red as needed.

 

[PSBoyce]

Welcome to the Board!

See if this works for you:

Sub SplitColumn()
Dim NumCols As Long, TopCell As Range, ResCell As Range, lr As Long
Dim r As Long, i As Long, n As Long

    NumCols = 14
    Set TopCell = Range("A2")
    Set ResCell = Range("C2")
    
    lr = Cells(Rows.Count, TopCell.Column).End(xlUp).Row - TopCell.Row + 1
    
    r = 0
    For i = 1 To NumCols
        n = lr \ NumCols + IIf(i <= lr Mod NumCols, 1, 0)
        ResCell.Offset(0, i - 1).Resize(n).Value = TopCell.Offset(r, 0).Resize(n).Value
        r = r + n
    Next i
    
End Sub

Change the values in red as needed.

Thank you Eric - this is EXACTLY what I was looking for (looking for several weeks)!

 

[Eric W]

Glad it works for you!