VBA for dividing spread sheet by rows

[Smilin]

I need to somehow divide evenly a spread sheet “Sheet 1”, having columns A to O, which is pendent on number of rows in a sheet per number of people in the office. Each section can be simply separated by thicker border line. I have a formula on a separate sheet “Entries #” which calculates how my rows are assigned to each person. Ie. 103 entries (rows) amongst 9 ppl Formula is =MOD(A1,A2)& " people get "&QUOTIENT(A1,A2)+1 and =A2-MOD(A1,A2) &" people get "&QUOTIENT(A1,A2) so this would have 4 people deal with 12 entries (rows) in the sheet and 5 people with deal with 11 rows in the sheet. These variables change daily.

What makes this worse, is that within the sheet there are a few black rows (conditional formatting) which are not to be counted as a row. This row doesn’t have useful data and most of the cells are empty, hence highlighting it black. For reference in this black line the cells in column A, B, C, are empty.

So I am not sure if a VBA can be written for this, having to refer to the Entries # where the formula is, and which would display the number of entries/ ppl in the office, or if conditional formatting would do, and I would have to change the number of rows per number of people in the office with in the conditional formatting formula, as needed. Thank you - gratitude.

 

[Snakehips]

Given that your black line cells are empty in columns A,B & C then maybe try this.
In sheet 'Entries #' , edit your formula so that C1 =MOD(A1,A2) D1 = "people get" E1 =QUOTIENT(A1,A2)+1. and similar for C2:E2. Thus the example values in C1, C2 are 4, 5 and E1, E2 are 12, 11

Then copy the below code to the Sheet1 code module and run it.

Sub AllocateEntries()
Application.ScreenUpdating = False
'Get Entries
With Sheets("Entries #")
Peeps1 = .Range("C1")
Ents1 = .Range("E1")
Peeps2 = .Range("C2")
Ents2 = .Range("E2")
End With
MyRows1 = Peeps1 * Ents1
MyRows2 = Peeps2 * Ents2
'Get last row
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
'Clear cell backgrounds
Range("A1:O" & Rows.Count).Interior.ColorIndex = -4142
ColInd = 20

'Loop through rows
For r = 1 To LastRow
'
If r > MyRows1 Then
MyRows1 = MyRows1 + MyRows2
Ents1 = Ents2
End If
'Check for empty row
If Len(Cells(r, 1) & Cells(r, 2) & Cells(r, 3)) = 0 Then
MyRows1 = MyRows1 + 1
GoTo Skip
End If
'Colour row
Range("A" & r & ":O" & r).Interior.ColorIndex = ColInd
Ents = Ents + 1
'Re-sets
If Ents = Ents1 Then
Ents = 0
If ColInd = 20 Then
ColInd = 2
Else
ColInd = 20
End If
End If
Skip:
Next

Application.ScreenUpdating = True

End Sub

Hope that helps

 

[Smilin]

I changed the formula a bit for it to work, however, when I ran the VBA it changed the color of my headers and nothing else happened. Here is a portion of what the Sheet 1 looks like along with the black lines. They need to stay, but not be counted. If your VBA sections of given set of lines with a black border line than perhaps that is the issue. Since the header turned almost aqua blue, I wonder if you are section it off with color and not thick border line. I do have 2 layer conditional formatting, when it gets assigned and after it is finished. TMI perhaps, I don't know. Can you still help?

 

[Snakehips]

Yes, was sectioning it with alternating bands of blue and white.

Try the below to allow for your header row and section with double line border.

Sub AllocateEntries2()
Sheets("Sheet1").Select
Application.ScreenUpdating = False
'Get Entries
With Sheets("Entries #")
Peeps1 = .Range("C1")
Ents1 = .Range("E1")
Peeps2 = .Range("C2")
Ents2 = .Range("E2")
End With
MyRows1 = Peeps1 * Ents1
MyRows2 = Peeps2 * Ents2
'Get last row based on cheque number
LastRow = Cells(Rows.Count, "B").End(xlUp).Row
'Clear cell borders
Range("A2:O" & Rows.Count).Borders.LineStyle = xlNone
'Loop through rows
For r = 2 To LastRow

If r > MyRows1 + 1 Then
MyRows1 = MyRows1 + MyRows2
Ents1 = Ents2
End If

'Check for empty row
If Len(Cells(r, 1) & Cells(r, 2) & Cells(r, 3)) = 0 Then
MyRows1 = MyRows1 + 1
GoTo Skip
End If

Ents = Ents + 1
'Re-sets
If Ents = Ents1 Then
Ents = 0
'Colour row
With Range("A" & r & ":O" & r).Borders(xlEdgeBottom)
        .LineStyle = xlDouble
        .Color = 0  '**edit to ' = -16776961 ' for red lines
        .Weight = xlThick
    End With
End If
Skip:
Next

Application.ScreenUpdating = True

End Sub

 

[Snakehips]

Requires Entries # to be eg....

Book1
	A	B	C	D	E
1	103	Total Entries	4	People Get	12
2	9	People	5	People Get	11
Entries #

Cell Formulas
Range	Formula
C1	C1	=MOD(A1,A2)
C2	C2	=A2-MOD(A1,A2)
E1	E1	=QUOTIENT(A1,A2)+1
E2	E2	=QUOTIENT(A1,A2)

Hope that helps.

 

[Smilin]

Yes, was sectioning it with alternating bands of blue and white.

Try the below to allow for your header row and section with double line border.

Sub AllocateEntries2()
Sheets("Sheet1").Select
Application.ScreenUpdating = False
'Get Entries
With Sheets("Entries #")
Peeps1 = .Range("C1")
Ents1 = .Range("E1")
Peeps2 = .Range("C2")
Ents2 = .Range("E2")
End With
MyRows1 = Peeps1 * Ents1
MyRows2 = Peeps2 * Ents2
'Get last row based on cheque number
LastRow = Cells(Rows.Count, "B").End(xlUp).Row
'Clear cell borders
Range("A2:O" & Rows.Count).Borders.LineStyle = xlNone
'Loop through rows
For r = 2 To LastRow

If r > MyRows1 + 1 Then
MyRows1 = MyRows1 + MyRows2
Ents1 = Ents2
End If

'Check for empty row
If Len(Cells(r, 1) & Cells(r, 2) & Cells(r, 3)) = 0 Then
MyRows1 = MyRows1 + 1
GoTo Skip
End If

Ents = Ents + 1
'Re-sets
If Ents = Ents1 Then
Ents = 0
'Colour row
With Range("A" & r & ":O" & r).Borders(xlEdgeBottom)
        .LineStyle = xlDouble
        .Color = 0  '**edit to ' = -16776961 ' for red lines
        .Weight = xlThick
    End With
End If
Skip:
Next

Application.ScreenUpdating = True

End Sub

 

[Smilin]

We're almost there...it sectioned it off, and I am thrilled - thank you. But it deleted all the border line (thin line) for all the cells in each section. Here is sample, if you want to compare it to the one I posted earlier. Even in Column P where thin line formatting should remain as I mentioned the spread sheet covers column A to O one of the cells, 2nd one from the double line has partially lost the thin border line. Would you be able to fix that? No rush Thank you. The grey block is to be there, nothing you did.

 

[Snakehips]

So are you saying that A2:O1000 is normally formatted with thin, black, cell borders?

 

[Smilin]

Yes all the thin border lines for each cell within the works sheet are gone. If you scroll up, there is an insert of what the spread sheet looks like before running your macro. I took a snip. For comparison I took a snip after I ran your macro...and the thin border lines are gone, and I see some grid lines but only in 3 columns.

 

[Snakehips]

Try this....

Sub AllocateEntries3()
Sheets("Sheet1").Select
Application.ScreenUpdating = False
'Get Entries
With Sheets("Entries #")
Peeps1 = .Range("C1")
Ents1 = .Range("E1")
Peeps2 = .Range("C2")
Ents2 = .Range("E2")
End With
MyRows1 = Peeps1 * Ents1
MyRows2 = Peeps2 * Ents2
'Get last row based on cheque number
LastRow = Cells(Rows.Count, "B").End(xlUp).Row
'Reset fine cell borders

With Range("A2:O1000").Borders
 .LineStyle = xlContinuous
        .Color = 2
        .Weight = xlThin
End With

'Loop through rows
For r = 2 To LastRow

If r > MyRows1 + 1 Then
MyRows1 = MyRows1 + MyRows2
Ents1 = Ents2
End If

'Check for empty row
If Len(Cells(r, 1) & Cells(r, 2) & Cells(r, 3)) = 0 Then
MyRows1 = MyRows1 + 1
GoTo Skip
End If

Ents = Ents + 1
'Re-sets
If Ents = Ents1 Then
Ents = 0
'Colour row
With Range("A" & r & ":O" & r).Borders(xlEdgeBottom)
        .LineStyle = xlDouble
        .Color = 0  '**edit to ' = 0-16776961 ' for red lines
        .Weight = xlThick
    End With
End If
Skip:
Next

Application.ScreenUpdating = True

End Sub

I have just noticed that if there is one of your black rows immediately below the double separation line, the line is difficult to see. You may wish to make the edit that sets the double separation lines red?