Roster Issue

[Raegan2016]

Hi All

I have been trying to create a roster that self populates horizontaly and highlights any overlap and also tracks positions.

The inputs are the start date, days on & days off. Id like to colour the different positions.

Roster.JPG

If anyone can help it would be greatly appreciated

Cheers

[xladept]

Attach a sample workbook. Make sure there is just enough data to demonstrate your need. Include a BEFORE sheet and an AFTER sheet in the workbook if needed to show the process you're trying to complete or automate. Make sure your desired results are shown, mock them up manually if necessary.

Remember to desensitize the data.

Click on GO ADVANCED and then scroll down to Manage Attachments to open the upload window (or use the paperclip icon).

[Raegan2016]

Hi All

I have been trying to create a roster that self populates horizontaly and highlights any overlap and also tracks positions.

The inputs are the start date, days on & days off. Id like to colour the different positions.

Attachment 459478

If anyone can help it would be greatly appreciated

Cheers

Is anyone able to assist. ???????

[xladept]

If you post a sample workbook, I'll try to help you and so may some others

[Raegan2016]

Sorry guys, I'm new to the format

http://www.excelforum.com/attachment...1&d=1463296869

[xladept]

Hi Raegan,

Try this:

Sub Raegan(): Dim SD As Date, Dn As Long, Df As Long
Dim r As Long, c As Long, F As Range, X As Range, n As Long
        n = Columns.Find("*", , , , xlByColumns, xlPrevious).column
Set F = Range("D:D").Find("Enter Start Date")
            If Not F Is Nothing Then
    Do
    r = F.Row: SD = F.Offset(0, 1): Dn = F.Offset(1, 1): Df = F.Offset(2, 1)
        c = 7: Cells(r + 1, c).Resize(2, n).Interior.ColorIndex = xlNone
        Do Until Cells(3, c) = SD: c = c + 1: Loop
                                    Do
              If c > n Then Exit Do
    Set X = Cells(r + 1, c).Resize(1, Dn): X.Interior.ColorIndex = 35
        X.Offset(1, Dn).Resize(1, Df).Interior.ColorIndex = 38
                c = c + Dn + Df:    Loop
        Cells(r + 1, n + 1).Resize(2, Dn + Df).Interior.ColorIndex = xlNone
                
        Set F = Range("D:D").FindNext(F)
    Loop Until F Is Nothing Or F.Row <= r
    End If

Directions for running the routine(s) just supplied

If you haven't used macros before you'll need to go to:
File- options - trust center -trust center settings - macro settings ,
the second option down (disable all macros with notification)

Then - Copy the code to the clipboard

Open your Workbook

Press ALT + F11 to open the Visual Basic Editor.

Select "Module" from the Insert menu

Type "Option Explicit" then paste the code under it

With the cursor between Sub and End Sub press F5 (F8 to Single Step)

OR

Press ALT + Q to close the code window.

Press ALT + F8 then double click on the macro name
*Be sure to save the book with the code as Macro-Enabled

[Raegan2016]

Hi

thanks for that but i have somehow caused in issue whilst trying to introduce some additional functions.

I want to add a count function adding personal per day and also seperate the positions to allow for constant onsite supervision and an L3

Any help would be appreciated.

Cheers

[Raegan2016]

anyone out there??? please help me out, it would make my life a lot easier at the moment??

thanks

[xladept]

This will at least take care of the unanticipated Days On = 0:

Sub Raegan(): Dim SD As Date, Dn As Long, Df As Long
Dim r As Long, c As Long, F As Range, X As Range, n As Long
        n = Columns.Find("*", , , , xlByColumns, xlPrevious).column
Set F = Range("D:D").Find("Enter Start Date")
            If Not F Is Nothing Then
    Do
    r = F.Row: SD = F.Offset(0, 1): Dn = F.Offset(1, 1): Df = F.Offset(2, 1)
        c = 7: Cells(r + 1, c).Resize(2, n).Interior.ColorIndex = xlNone
        Do Until Cells(3, c) = SD: c = c + 1: Loop
                                    Do
              If c > n Then Exit Do
              If Dn Then
    Set X = Cells(r + 1, c).Resize(1, Dn): X.Interior.ColorIndex = 35
        X.Offset(1, Dn).Resize(1, Df).Interior.ColorIndex = 38
            Else
    Set X = Cells(r + 2, c).Resize(1, n - c + 1): X.Interior.ColorIndex = 38
            End If
                c = c + Dn + Df:    Loop
        Cells(r + 1, n + 1).Resize(2, Dn + Df).Interior.ColorIndex = xlNone

        Set F = Range("D:D").FindNext(F)
    Loop Until F Is Nothing Or F.Row <= r
    End If

End Sub

[xladept]

Hi Raegan,

To do what you're asking, I'd need more explanation - some examples would be even better

[Raegan2016]

I need the rostered days on to link to the title. as attached.

[xladept]

This works

Sub Raegan(): Dim SD As Date, Dn As Long, Df As Long
Dim r As Long, c As Long, F As Range, X As Range, n As Long
        n = Columns.Find("*", , , , xlByColumns, xlPrevious).column
Set F = Range("D:D").Find("Enter Start Date")
            If Not F Is Nothing Then
    Do
    r = F.Row: SD = F.Offset(0, 1): Dn = F.Offset(1, 1): Df = F.Offset(2, 1)
        c = 7: Cells(r + 1, c).Resize(2, n).Interior.ColorIndex = xlNone
        Do Until Cells(3, c) = SD: c = c + 1: Loop
                                    Do
              If c > n Then Exit Do
              If Dn Then
    Set X = Cells(r + 1, c).Resize(1, Dn): X.Interior.ColorIndex = 35
                    X.Value = Cells(r, 3)
        X.Offset(1, Dn).Resize(1, Df).Interior.ColorIndex = 38
            Else
    Set X = Cells(r + 2, c).Resize(1, n - c + 1): X.Interior.ColorIndex = 38
            End If
                c = c + Dn + Df:    Loop
        Cells(r + 1, n + 1).Resize(2, Dn + Df).Interior.ColorIndex = xlNone

        Set F = Range("D:D").FindNext(F)
    Loop Until F Is Nothing Or F.Row <= r
    End If

End Sub

[adamshek]

Hi I have a column that includes positive and some of the positive have matching negative numbers I like to search for the pairs of positive and negative and write the pairs first then the rest of the numbers. Here is an example
1
2
3
4
5
-1
-2

after sorting the column should look like this:
1
-1
2
-2
3
4
5

I appreciate your help.