• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

VBA Code to split a range on cells equally

sn152

sn152

Member
Hi All,

I am trying to do a macro which will split a data range equally.

For example, in the attached workbook I have data in sheet1 in cells from A1 to E15.

I want that to be split equally among 6 teams (team A, B, C, D, E, F) and paste the split data in a separate workbook. I have also attached that workbook.

Please help me with this.
Thanks in advance...
 

Attachments

  • Sample.xlsx
    8.9 KB · Views: 45
  • Output.xlsx
    9.1 KB · Views: 40
This should do it for you. Just make sure to list all your teams where commented.
Code: 
Sub DivideTeams()
Dim TeamList()
Dim TeamCount As Long
Dim recCount As Long
Dim evenDiv As Long
Dim extraRecs As Long
Dim lastRow As Long
Dim teamChoice As Long
Dim i As Long
Dim j As Long

'Who are the teams?
TeamList = Array("Team A", "Team B", "Team C", "Team D", "Team E", "Team F")

teamChoice = 0
TeamCount = UBound(TeamList) + 1
i = 1

Application.ScreenUpdating = False
'Make new workbook
ActiveSheet.Copy

With ActiveSheet
    'Math calculations
    lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    recCount = lastRow - 1
    TeamCount = UBound(TeamList) + 1
    extraRecs = recCount Mod TeamCount
    evenDiv = (recCount - extraRecs) / TeamCount
   
    Do While i < lastRow
        'Every team gets at least the same amount
        For j = 1 To evenDiv
            i = i + 1
            .Cells(i, "F").Value = TeamList(teamChoice)
        Next j
       
        'Check if uneven amount, and if so, add a line
        If j = evenDiv + 1 And extraRecs > 0 Then
            i = i + 1
            .Cells(i, "F").Value = TeamList(teamChoice)
            extraRecs = extraRecs - 1
        End If
        'Next team queued up
        teamChoice = teamChoice + 1
    Loop

End With
Application.ScreenUpdating = True
End Sub
 
Hi Luke,

One more request. Can we have the team names to show in the last column instead of mentioning it as "F".
 
Sure thing. Added a few lines to deal with new variable, lastCol
Code: 
Sub DivideTeams()
Dim TeamList()
Dim TeamCount As Long
Dim recCount As Long
Dim evenDiv As Long
Dim extraRecs As Long
Dim lastRow As Long
Dim lastCol As Long
Dim teamChoice As Long
Dim i As Long
Dim j As Long

'Who are the teams?
TeamList = Array("Team A", "Team B", "Team C", "Team D", "Team E", "Team F")

teamChoice = 0
TeamCount = UBound(TeamList) + 1
i = 1

Application.ScreenUpdating = False
'Make new workbook
ActiveSheet.Copy

With ActiveSheet
    'Math calculations
   lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
   'Always find the first blank column
   lastCol = .Cells(1, Columns.Count).End(xlToLeft).Column + 1
    recCount = lastRow - 1
    TeamCount = UBound(TeamList) + 1
    extraRecs = recCount Mod TeamCount
    evenDiv = (recCount - extraRecs) / TeamCount
   
    Do While i < lastRow
        'Every team gets at least the same amount
       For j = 1 To evenDiv
            i = i + 1
            .Cells(i, lastCol).Value = TeamList(teamChoice)
        Next j
       
        'Check if uneven amount, and if so, add a line
       If j = evenDiv + 1 And extraRecs > 0 Then
            i = i + 1
            .Cells(i, lastCol).Value = TeamList(teamChoice)
            extraRecs = extraRecs - 1
        End If
        'Next team queued up
       teamChoice = teamChoice + 1
    Loop

End With
Application.ScreenUpdating = True
End Sub
 
Hi Luke,

Also I need to add a Heading to the last column as "Assigned to". Can you pls help me..
 
Add a line at the end, just before the "End With" saying:
Code: 
.Cells(1, lastCol).Value = "Assigned to"
 
@sn152

Just a personal query on your post, you mentioned in your 1st post that you want to divide equally, but what I can see Team A & B has 3 records each and Team C, D & E has two records each. So my question is it really equal and on what basis?

Regards,
 
@Somendra Misra

Equal in the sense, if the total count is a number which cannot be divided equally then there will be a increase in the number assigned to one or two teams...
 
Ok @sn152 .... But there will not be why A & B only get 3 if we made an array of teams like {E;C;D;B;A} then E and C will get 3.
Will this hamper the result?

Regards,
 
@Luke M

Hi Luke,

The above code by you splits the data range equally among the teams.
But for example when we have 7 rows filled in the sheet, we cannot split it equally among six teams. 1 team may get more numbers. In this case for example if there are 7 rows are filled, can we have 6 rows split among the 6 teams and remaining 1 row should not be assigned. Can we do it this way?

Please help me with this.

Thanks in advance!
 
Yep. I added in a MsgBox to prompt user if extra rows found.
Code: 
Sub DivideTeams()
Dim TeamList()
Dim TeamCount As Long
Dim recCount As Long
Dim evenDiv As Long
Dim extraRecs As Long
Dim lastRow As Long
Dim lastCol As Long
Dim teamChoice As Long
Dim i As Long
Dim j As Long
Dim skipExtra As Boolean

skipExtra = False

'Who are the teams?
TeamList = Array("Team A", "Team B", "Team C", "Team D", "Team E", "Team F")

teamChoice = 0
TeamCount = UBound(TeamList) + 1
i = 1

Application.ScreenUpdating = False
'Make new workbook
ActiveSheet.Copy

With ActiveSheet
    'Math calculations
  lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
   'Always find the first blank column
  lastCol = .Cells(1, Columns.Count).End(xlToLeft).Column + 1
    recCount = lastRow - 1
    TeamCount = UBound(TeamList) + 1
    extraRecs = recCount Mod TeamCount
    If extraRecs > 0 Then
        If vbYes <> MsgBox("Click yes to create uneven teams" & vbNewLine & _
            "or click no to ignore extra lines", vbYesNo, "Extra lines found") Then
            lastRow = lastRow - extraRecs
           
            skipExtra = True
        End If
    End If
    evenDiv = (recCount - extraRecs) / TeamCount
   
    Do While i < lastRow
        'Every team gets at least the same amount
      For j = 1 To evenDiv
            i = i + 1
            .Cells(i, lastCol).Value = TeamList(teamChoice)
        Next j
       
        'Check if uneven amount, and if so, add a line
      If j = evenDiv + 1 And extraRecs > 0 And skipExtra = False Then
            i = i + 1
            .Cells(i, lastCol).Value = TeamList(teamChoice)
            extraRecs = extraRecs - 1
        End If
        'Next team queued up
      teamChoice = teamChoice + 1
    Loop

End With
Application.ScreenUpdating = True
End Sub
 
Hello Luke,

i am trying to modify your code, as i want to input the list of team members from another worksheet, instead of defining it in the code. after modification i am getting an error by saying that "Runtime error 9: Script out of Range"

could you please help me here. Below is modified Code.

Sub DivideTeams()
Dim TeamList As Variant
'Dim TeamList()
Dim SourceTeam As Range
Dim TeamCount As Long
Dim recCount As Long
Dim evenDiv As Long
Dim extraRecs As Long
Dim lastRow As Long
Dim lastCol As Long
Dim teamChoice As Long
Dim i As Long
Dim j As Long
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet


Set ws1 = Sheets("Team")
Set ws3 = Sheets("Consolidation Tracker")
With ws1

Dim lastRow1 As Long
Dim lastRow2 As Long
lastRow1 = Sheets("Team").Cells(.Rows.Count, "A").End(xlUp).Row
lastRow2 = Sheets("In Team").Range("A:A").End(xlUp).Row
For i = 5 To lastRow1
lastRow2 = Sheets("In Team").Range("A:A").End(xlUp).Row

If ws1.Cells(i, 2) = "In" Then ws1.Cells(i, 1).Copy Destination:=Sheets("In Team").Range("A100").End(xlUp)(2, 1)

Next i

End With

'Who are the teams?
'TeamList = Array("Team A", "Team B", "Team C", "Team D", "Team E", "Team F")

Set SourceTeam = Sheets("In Team").Range("A1:A5").CurrentRegion
TeamList = SourceTeam.Value
teamChoice = 0
TeamCount = UBound(TeamList) + 1
i = 1

Application.ScreenUpdating = False
'Make new workbook
ws3.Copy
'ActiveSheet.Copy

With ActiveSheet
'Math calculations
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
'Always find the first blank column
lastCol = .Cells(1, Columns.Count).End(xlToLeft).Column + 1
recCount = lastRow - 1
TeamCount = UBound(TeamList) + 1
extraRecs = recCount Mod TeamCount
evenDiv = (recCount - extraRecs) / TeamCount

Do While i < lastRow
'Every team gets at least the same amount
For j = 1 To evenDiv
i = i + 1
.Cells(i, lastCol).Value = TeamList(teamChoice) 'in this line i am geeting error as Runtime error, script our of range
Next j

'Check if uneven amount, and if so, add a line
If j = evenDiv + 1 And extraRecs > 0 Then
i = i + 1
.Cells(i, lastCol).Value = TeamList(teamChoice)
extraRecs = extraRecs - 1
End If
'Next team queued up
teamChoice = teamChoice + 1
Loop
.Cells(1, lastCol).Value = "Assigned to"
End With
Application.ScreenUpdating = True
End Sub
 
Hi Anudeep, and welcome to the forum. :awesome:

Since the values of TeamList are coming from a range now, it's actually a 2D array rather than a 1D. As such, need to provide 2 arguments. See if this works better for you.
Code: 
Sub DivideTeams()
    Dim TeamList As Variant
    Dim SourceTeam As Range
    Dim TeamCount As Long
    Dim recCount As Long
    Dim evenDiv As Long
    Dim extraRecs As Long
    Dim lastRow As Long
    Dim lastCol As Long
    Dim teamChoice As Long
    Dim i As Long
    Dim j As Long
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim ws3 As Worksheet
    Dim lastRow1 As Long
    Dim lastRow2 As Long
   
    Application.ScreenUpdating = False
   
    Set ws1 = Sheets("Team")
    Set ws3 = Sheets("Consolidation Tracker")
   
    With ws1
   
       
        lastRow1 = .Cells(.Rows.Count, "A").End(xlUp).Row
        lastRow2 = Sheets("In Team").Range("A:A").End(xlUp).Row
        For i = 5 To lastRow1
            lastRow2 = Sheets("In Team").Range("A:A").End(xlUp).Row
           
            If .Cells(i, 2) = "In" Then .Cells(i, 1).Copy Destination:=Sheets("In Team").Range("A100").End(xlUp)(2, 1)
           
        Next i
   
    End With
   
    'Who are the teams?
    'TeamList = Array("Team A", "Team B", "Team C", "Team D", "Team E", "Team F")
   
    Set SourceTeam = Sheets("In Team").Range("A1:A5")
    TeamList = SourceTeam.Value
    teamChoice = 1
    TeamCount = UBound(TeamList)
    i = 1
   
   
    'Make new workbook
    ws3.Copy
    'ActiveSheet.Copy
   
    With ActiveSheet
        'Math calculations
        lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        'Always find the first blank column
        lastCol = .Cells(1, Columns.Count).End(xlToLeft).Column + 1
        recCount = lastRow - 1
       
        extraRecs = recCount Mod TeamCount
        evenDiv = (recCount - extraRecs) / TeamCount
       
        Do While i < lastRow
            'Every team gets at least the same amount
            For j = 1 To evenDiv
                i = i + 1
                'since TeamList is from a range, it's now a 2D array, so needs 2 arguments
                .Cells(i, lastCol).Value = TeamList(teamChoice, 1)
            Next j
           
            'Check if uneven amount, and if so, add a line
            If j = evenDiv + 1 And extraRecs > 0 Then
                i = i + 1
                .Cells(i, lastCol).Value = TeamList(teamChoice, 1)
                extraRecs = extraRecs - 1
            End If
            'Next team queued up
            teamChoice = teamChoice + 1
        Loop
        .Cells(1, lastCol).Value = "Assigned to"
    End With
    Application.ScreenUpdating = True
End Sub
 
Hi Luke,

Hope this is still active and that I'm able to highjack this tread. I have been using your code and it works well, thank you. The only thing that I have been struggling with is getting your code to look at values in said col and assign equally, but first look at the values and group any unique values to one team. I have a list of orders (Sometimes duplicated) and currently its then being split between different teams.

Would appreciate any help.
 
Hi Moondog. Could you give a sample of what you mean (what you have now + what you want it to look like)?
 
Hello people,

Can anyone help me for VBA code. Below is the matter.

I have a excel main sheet named (Main) which contains bulk data.
other worksheets named A, B, C, D

I want to apply filter first in main sheet then distribute those rows equally in other sheets.

Again, i want to apply filter in header and resulting rows should divide and add in other sheets equally.

and so on...... in same way.



Thanks in Advance.....
 
gurtej
As You've read from Forum Rules ( New Users - Please Start Here >> )
Start a new post every time you ask a question, even if the theme is similar. The original author may continue asking questions whilst the post is in progress and of course if you are answering questions you may need to ask questions of the initial poster.
​
 
You must log in or register to reply here.
Back
Top