vba Rotating list based on font-HARD

P

PickeMe0304

New Member
Joined
Sep 23, 2011
Messages
4
Hello, I have a hard/weird one. My friends and I have a rotating driving list so that every time we have an event the people at the top of the list have to drive. Here is the trick, the people that don't attend the event do not move up the list. So I been trying to create a vba program where the people attended (in red font) will move up and the people that didn't attend (black) will not move. Sounds simple but I've been working on it forever and I can't figure it out!


Before
1
2 (red)
3 (red)
4
5
6 (red)
8
9 (red)
10 (red)
11 (red)
12
13
14
15
16 (red)


After
2
3
1
6
4
5
9
10
11
8
16
12
13
14
15
 

Excel Facts

Add Bullets to Range
Select range. Press Ctrl+1. On Number tab, choose Custom. Type Alt+7 then space then @ sign (using 7 on numeric keypad)
Sort by date Sort by votes
Try this:-
Results in column (C).
Code: 
[COLOR=navy]Sub[/COLOR] MG23Sep23
[COLOR=navy]Dim[/COLOR] Rng     [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Dim[/COLOR] Dn      [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Dim[/COLOR] n       [COLOR=navy]As[/COLOR] [COLOR=navy]Integer[/COLOR]
[COLOR=navy]Dim[/COLOR] c       [COLOR=navy]As[/COLOR] [COLOR=navy]Integer[/COLOR]
[COLOR=navy]Set[/COLOR] Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
ReDim ray(1 To Rng.Count)
[COLOR=navy]For[/COLOR] n = 1 To 2
    [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] Dn [COLOR=navy]In[/COLOR] Rng
        [COLOR=navy]If[/COLOR] n = 1 And Dn.Font.ColorIndex = 3 [COLOR=navy]Then[/COLOR]
            c = c + 1
            ray(c) = Dn
        [COLOR=navy]ElseIf[/COLOR] n = 2 And Not Dn.Font.ColorIndex = 3 [COLOR=navy]Then[/COLOR]
            c = c + 1
            ray(c) = Dn
        [COLOR=navy]End[/COLOR] If
    [COLOR=navy]Next[/COLOR] Dn
[COLOR=navy]Next[/COLOR] n
'Change to Range("A1")----    to overwrite Data.
Range("C1").Resize(Rng.Count) = Application.Transpose(ray)
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]
Regards Mick
 
Upvote 0
Thanks for the quick response but it didn't do exactly what I wanted it to do. This program gathered all the numbers in red font and moved them at the top (in order) and put the other numbers at the bottom of the list. I guess the best way to describe it is...First recognize if the first cell is red. If it is not red, then recognize where the first set of consecutive reds are and copy that to the top of the list. Second recognize the first set of blacks and move that list under the reds. Third, recognize the next set of reds and move that list under the black. It will go back and forth until it went through the list. Now, if the first cell is red then move the first set and second set of reds over to the list. Second get the first set of blacks and move that over. Third get the 3rd set of red and move over. Then black, and so forth. I hope this makes sense.
 
Upvote 0
Try this, Results in column (D).
Code: 
[COLOR="Navy"]Sub[/COLOR] MG24Sep23
[COLOR="Navy"]Dim[/COLOR] Rng      [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Dn       [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Rrng     [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Brng     [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] c        [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] n        [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer[/COLOR]
[COLOR="Navy"]Dim[/COLOR] B        [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] R        [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] max      [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer[/COLOR]
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
ReDim ray(1 To Rng.Count)
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    [COLOR="Navy"]If[/COLOR] Dn.Font.ColorIndex = 3 [COLOR="Navy"]Then[/COLOR]
        [COLOR="Navy"]If[/COLOR] Rrng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
            [COLOR="Navy"]Set[/COLOR] Rrng = Dn
        [COLOR="Navy"]Else[/COLOR]
            [COLOR="Navy"]Set[/COLOR] Rrng = Union(Rrng, Dn)
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Else[/COLOR]
        [COLOR="Navy"]If[/COLOR] Brng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
            [COLOR="Navy"]Set[/COLOR] Brng = Dn
        [COLOR="Navy"]Else[/COLOR]
            [COLOR="Navy"]Set[/COLOR] Brng = Union(Brng, Dn)
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] Dn
max = Application.max(Rrng.Areas.Count, Brng.Areas.Count)
[COLOR="Navy"]For[/COLOR] n = 1 To max
    [COLOR="Navy"]If[/COLOR] n <= Rrng.Areas.Count [COLOR="Navy"]Then[/COLOR]
        [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] R [COLOR="Navy"]In[/COLOR] Rrng.Areas(n)
            c = c + 1
            ray(c) = R
        [COLOR="Navy"]Next[/COLOR] R
 [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]If[/COLOR] n <= Brng.Areas.Count [COLOR="Navy"]Then[/COLOR]
  [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] B [COLOR="Navy"]In[/COLOR] Brng.Areas(n)
        c = c + 1
        ray(c) = B
    [COLOR="Navy"]Next[/COLOR] B
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] n
Range("D1").Resize(Rng.Count) = Application.Transpose(ray)
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
Very very close. When the first cell is not red, it does exactly what I wanted it to do, but when the first cell is red it copy and paste the column to column D. Is it also possible to keep the font style the same? I appreciate the help.
 
Upvote 0
Try this :-
Results in column "C".
Code: 
[COLOR="Navy"]Sub[/COLOR] MG25Sep36
[COLOR="Navy"]Dim[/COLOR] Rng      [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Dn       [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Rrng     [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Brng     [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] c        [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] n        [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer[/COLOR]
[COLOR="Navy"]Dim[/COLOR] B        [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] R        [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] max      [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer[/COLOR]
[COLOR="Navy"]Dim[/COLOR] TRng     [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] t        [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
ReDim ray(1 To Rng.Count, 1 To 2)
[COLOR="Navy"]If[/COLOR] Rng(1).Font.ColorIndex = 3 [COLOR="Navy"]Then[/COLOR]
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
        [COLOR="Navy"]If[/COLOR] Not Dn.Font.ColorIndex = 3 [COLOR="Navy"]Then[/COLOR]
            [COLOR="Navy"]Set[/COLOR] TRng = Rng(1).Resize(Dn.Row - 1)
            [COLOR="Navy"]Set[/COLOR] Rng = Range(Cells(Dn.Row, 1), Cells(Rows.Count, 1).End(xlUp))
            [COLOR="Navy"]Exit[/COLOR] For
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]End[/COLOR] If

[COLOR="Navy"]If[/COLOR] Not TRng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] t [COLOR="Navy"]In[/COLOR] TRng
        c = c + 1
        ray(c, 1) = t: ray(c, 2) = 3
    [COLOR="Navy"]Next[/COLOR] t
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    [COLOR="Navy"]If[/COLOR] Dn.Font.ColorIndex = 3 [COLOR="Navy"]Then[/COLOR]
        [COLOR="Navy"]If[/COLOR] Rrng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
            [COLOR="Navy"]Set[/COLOR] Rrng = Dn
        [COLOR="Navy"]Else[/COLOR]
            [COLOR="Navy"]Set[/COLOR] Rrng = Union(Rrng, Dn)
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Else[/COLOR]
        [COLOR="Navy"]If[/COLOR] Brng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
            [COLOR="Navy"]Set[/COLOR] Brng = Dn
        [COLOR="Navy"]Else[/COLOR]
            [COLOR="Navy"]Set[/COLOR] Brng = Union(Brng, Dn)
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]If[/COLOR] Rrng [COLOR="Navy"]Is[/COLOR] Nothing Or Brng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR] [COLOR="Navy"]Exit[/COLOR] [COLOR="Navy"]Sub[/COLOR]
max = Application.max(Rrng.Areas.Count, Brng.Areas.Count)
[COLOR="Navy"]For[/COLOR] n = 1 To max
    [COLOR="Navy"]If[/COLOR] n <= Rrng.Areas.Count [COLOR="Navy"]Then[/COLOR]
        [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] R [COLOR="Navy"]In[/COLOR] Rrng.Areas(n)
            c = c + 1
            ray(c, 1) = R: ray(c, 2) = 3
        [COLOR="Navy"]Next[/COLOR] R
 [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]If[/COLOR] n <= Brng.Areas.Count [COLOR="Navy"]Then[/COLOR]
  [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] B [COLOR="Navy"]In[/COLOR] Brng.Areas(n)
        c = c + 1
        ray(c, 1) = B: ray(c, 2) = 1
    [COLOR="Navy"]Next[/COLOR] B
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] n
[COLOR="Navy"]For[/COLOR] n = 1 To UBound(ray)
    [COLOR="Navy"]With[/COLOR] Cells(n, 3)
        .Value = ray(n, 1)
        .Font.ColorIndex = ray(n, 2)
    [COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]Next[/COLOR] n
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
You must log in or register to reply here.

Similar threads

R
  • Question Question
Need Macro/VBA code for a rotating list
Replies
3
Views
123
mumps
mumps
H
  • Solved
VBA Font Conditional Formatting based on cell value change - but it doesn't trigger
Replies
3
Views
76
hcgood
H
D
  • Solved
Is there a quick way to create / fill this list
2 3
Replies
20
Views
415
Eric W
Eric W
N
  • Question Question
Help w/ Excel Formula
Replies
4
Views
152
JGordon11
JGordon11
D
  • Solved
Telephone numbers are Hard!
2
Replies
10
Views
334
dowtym
D

Forum statistics

Threads
1,224,521
Messages
6,179,285
Members
452,902
Latest member
Knuddeluff

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top