VBA to sort/distribute evenly

[liampog]

Hi

I have a list of data that will include numbers 1,2,3,4. First, I have some code that sorts into ascending order, but then I'd like some more code that then distributes the list as follows. Original in Column A and the desired order in Column C. In this example, there are 6x 1, 8x 2, 5x 3, 6x 4:

Note cell C23 is 4 because the 3's have run out. Also note cells C24 and C25 because there are 2 more 2's left over.

	A	B	C
1	1		1
2	1		2
3	1		3
4	1		4
5	1		1
6	1		2
7	2		3
8	2		4
9	2		1
10	2		2
11	2		3
12	2		4
13	2		1
14	2		2
15	3		3
16	3		4
17	3		1
18	3		2
19	3		3
20	4		4
21	4		1
22	4		2
23	4		4
24	4		2
25	4		2

<tbody>
</tbody>

 

[MickG]

Try this:-
NB:- The last 4 rows are not Quite in the same order as your Data, Does that Matter??

[COLOR="Navy"]Sub[/COLOR] MG21Dec14
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    [COLOR="Navy"]If[/COLOR] Not .Exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
        .Add Dn.Value, 1
    [COLOR="Navy"]Else[/COLOR]
        .Item(Dn.Value) = .Item(Dn.Value) + 1
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
oMax = Application.Max(.keys())
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    c = c + 1
    c = IIf(c = oMax + 1, 1, c)
    [COLOR="Navy"]If[/COLOR] .Item(c) = 0 [COLOR="Navy"]Then[/COLOR]
        [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] k [COLOR="Navy"]In[/COLOR] .keys
            [COLOR="Navy"]If[/COLOR] Not .Item(k) = 0 [COLOR="Navy"]Then[/COLOR]
                Dn.Offset(, 2).Value = k
                .Item(k) = .Item(k) - 1
                [COLOR="Navy"]Exit[/COLOR] For
            [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]Next[/COLOR] k
    [COLOR="Navy"]Else[/COLOR]
        Dn.Offset(, 2).Value = c
        .Item(c) = .Item(c) - 1
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[liampog]

Hi Mick

This works perfectly but I don't think I've explained myself properly

This is more a sorting thing rather than taking a set of data and changing it into something else.

If we say that Column B has unique staff names with each staff member assigned a category number in Column A.

I'd like to sort the numbers (and corresponding names) into the order in Column C.

Does that make better sense?

 

[MickG]

Can you show an example of that !!!

 

[liampog]

Sure...

So the data would start as below.....

	A (name)	B (category)
1	Staff 1	1
2	Staff 2	1
3	Staff 3	1
4	Staff 4	1
5	Staff 5	2
6	Staff 6	2
7	Staff 7	2
8	Staff 8	2
9	Staff 9	2
10	Staff 10	2
11	Staff 11	3
12	Staff 12	3
13	Staff 13	3
14	Staff 14	3
15	Staff 15	3
16	Staff 16	3
17	Staff 17	3
18	Staff 18	4
19	Staff 19	4
20	Staff 20	4

<tbody>
</tbody>

and end up as below after sorting it somehow?

Maybe there needs to be a helper column in C that assigns 1 to 20?

	A (name)	B (category)
1	Staff 1	1
2	Staff 5	2
3	Staff 11	3
4	Staff 18	4
5	Staff 2	1
6	Staff 6	2
7	Staff 12	3
8	Staff 19	4
9	Staff 3	1
10	Staff 7	2
11	Staff 13	3
12	Staff 20	4
13	Staff 4	1
14	Staff 8	2
15	Staff 14	3
16	Staff 9	2
17	Staff 15	3
18	Staff 10	2
19	Staff 16	3
20	Staff 17	3

<tbody>
</tbody>

 

[MickG]

I'm not sure if this meets your requirements.
You will see the bottom 4 rows are not as per your results, but are they acceptable ???

Staff 1	1
Staff 5	2
Staff 11	3
Staff 18	4
Staff 2	1
Staff 6	2
Staff 12	3
Staff 19	4
Staff 3	1
Staff 7	2
Staff 13	3
Staff 20	4
Staff 4	1
Staff 8	2
Staff 14	3
Staff 9	2
Staff 10	2
Staff 15	3
Staff 16	3
Staff 17	3

<colgroup><col width="102" style="width: 77pt; mso-width-source: userset; mso-width-alt: 3640;"> <col width="113" style="width: 85pt; mso-width-source: userset; mso-width-alt: 4010;"> <tbody> </tbody>

 

[liampog]

Yes they are acceptable because there are no other 1s and 2s categories.

 

[MickG]

Try this:-
NB:- This code will overwrite the data in "column "A & B".

[COLOR="Navy"]Sub[/COLOR] MG22Dec03
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] oMax [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Q [COLOR="Navy"]As[/COLOR] Variant, K [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("B2"), Range("B" & Rows.Count).End(xlUp))
ReDim ray(1 To Rng.Count, 1 To 2)
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    [COLOR="Navy"]If[/COLOR] Not .Exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
        .Add Dn.Value, Array(Dn, 1)
    [COLOR="Navy"]Else[/COLOR]
       Q = .Item(Dn.Value)
        Q(1) = Q(1) + 1
           [COLOR="Navy"]Set[/COLOR] Q(0) = Union(Q(0), Dn)
        .Item(Dn.Value) = Q
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
oMax = Application.Max(.keys())
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    c = c + 1
    c = IIf(c = oMax + 1, 1, c)
    [COLOR="Navy"]If[/COLOR] .Item(c)(1) = 0 [COLOR="Navy"]Then[/COLOR]
      [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] .keys
            [COLOR="Navy"]If[/COLOR] Not .Item(K)(1) = 0 [COLOR="Navy"]Then[/COLOR]
               ray(Dn.Row - 1, 2) = K
                Q = .Item(K)
                    Q(1) = Q(1) - 1
                .Item(K) = Q
                [COLOR="Navy"]Exit[/COLOR] For
            [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]Next[/COLOR] K
     [COLOR="Navy"]Else[/COLOR]
        ray(Dn.Row - 1, 2) = c
         Q = .Item(c)
            Q(1) = Q(1) - 1
         .Item(c) = Q
     [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]For[/COLOR] n = 1 To Rng.Count
    Q = .Item(ray(n, 2))
        Q(1) = Q(1) + 1
        ray(n, 1) = Q(0)(Q(1)).Offset(, -1).Value
    .Item(ray(n, 2)) = Q
[COLOR="Navy"]Next[/COLOR] n
[COLOR="Navy"]End[/COLOR] With
Range("A2").Resize(Rng.Count, 2) = ray
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick