splitting a range to a variable number

[adygelber]

Hello all,

I have to split a range (with a variable number of rows and a fixed number of columns) to a variable number of persons (stated in a column from another worksheet).
Basically, in Sheet1 I have in column B a list of names (for example: B3="A", B4="B", B5="C"). Can be a list of 3 names, 4 names or any number of names.

In Sheet2 I have a range of data which has 12 columns and a variable number of rows.

Now, I want to divide equally the rows from Sheet2 to the names from Sheet1.Column B, by creating a new WorkSheet for every name.

For example: If I have 3 names and in Sheet2 a range of data with 10 rows and 12 columns, I want to create 3 new WorkSheets (one for every name) and in every WorkSheet I want to have an equal number of rows, as following:

Sheet Name1: rows 1-4
Sheet Name2: rows 5-7
Sheet Name3: rows 8-10

By this way I splitted the list equally to the 3 names and the first name receives an extra row because 10 Mod 3 is 1, therefore remains a row undistributed.

Can anyone help me with an idea of how to write this in VBA? I tried with two FOR loops but I didn't manage to configure them properly.

Thank you in advance!

[Bob Phillips]

Public Sub SplitData()
Dim lastrow As Long
Dim lastrow2 As Long
Dim nextrow As Long
Dim numrows As Long
Dim copyrows As Long
Dim remain As Long
Dim i As Long

    Application.ScreenUpdating = False
    
    With Worksheets("Sheet2")
    
        lastrow2 = .Cells(.Rows.Count, "A").End(xlUp).Row
    End With
    
    With Worksheets("Sheet1")
    
        lastrow = .Cells(.Rows.Count, "B").End(xlUp).Row
        numrows = lastrow2 \ (lastrow - 1)
        remain = lastrow2 - (numrows * (lastrow - 1))
        nextrow = 1
        For i = 2 To lastrow
        
            Worksheets.Add after:=Worksheets(Worksheets.Count)
            ActiveSheet.Name = .Cells(i, "B").Value
            copyrows = numrows + IIf(remain > 0, 1, 0)
            remain = remain - 1
            Worksheets("Sheet2").Rows(nextrow).Resize(copyrows).Copy ActiveSheet.Rows(1)
            nextrow = nextrow + copyrows
        Next i
    End With
    
    Application.ScreenUpdating = True
End Sub

[adygelber]

Thanks a lot!