Macro for allocation

I think it's a safe bet that no one knows what you're trying to do or how the results should appear.

Is it something like this?

Sub som(): Dim N As Range, r2 As Long, r1 As Long
Dim w1 As Worksheet, w2 As Worksheet, u As Long
Set w1 = Sheets("Sheet1"): Set w2 = Sheets("Sheet2")
r2 = w2.Columns(1).Find("*", , , , xlByRows, xlPrevious).Row
r1 = w1.Columns(1).Find("*", , , , xlByRows, xlPrevious).Row
w1.Cells(1, 3) = "Name"
Set N = w2.UsedRange.Range("A2:A" & r2)
For u = 2 To r1 Step r2 - 1: N.Copy w1.Cells(u, 3): Next u
w1.UsedRange.Offset(r1).Clear: w1.Columns.AutoFit
End Sub

That was great , only one small change you have divided based on the count of lines now if run teh macro it gives me 22 lines or 21 lines per person , but the name should be printed in sheet1 based on the sum of coloumn b divided equally among all the people.when some thing is more than average you can leave that coulmn blank. I have attached the file for reference.

Hi Som,

I've been trying - have yet to figure lines 554,669,1080

Hi Som,

I need instructions on how to handle those three lines all with action counts more than the average.

Hi Som,

I'm submitting your request to the Forum at large. My poor old brain has come up with nothing better than my original idea

I belive I understand what is happening,.
Sum in Sheet1 column B, divide by the name count in sheet2 column A

In the sample provided it is rounded to 132, so for every total of 132 in column B, we want 1 name.

This is just a start, I am having problems right now to get the start row working properly.

Hopefully others can add on to the code to get it working properly.

Sub Button1_Click()
    Dim sh As Worksheet, ws As Worksheet
    Dim rng As Range, LstRw As Long
    Dim x As Long, y As Long, av As Long
    Dim sm As Long, r As Long, r1 As Long

    Set sh = Sheets("Sheet1")
    Set ws = Sheets("Sheet2")

    With sh
        LstRw = .Cells(.Rows.Count, "B").End(xlUp).Row
        Set rng = .Range("B2:B" & LstRw)
        .Range("C2:C" & LstRw).ClearContents

    End With

    x = Application.WorksheetFunction.CountA(ws.Range("A:A")) - 1
    y = Application.Sum(rng)
    av = Fix(y / x)
    k = 1

    r1 = sh.Cells(sh.Rows.Count, "C").End(xlUp).Row + 1
    If r1 = 2 Then r1 = 2

    For Each c In rng.Cells
        sm = c + sm
        If sm > av Then
            k = k + 1
            r = c.Row - 1
            sh.Range("C" & r1 & ":C" & r).Value = ws.Cells(k, "A").Value
            sm = 0
            r1 = r1 + r - 1
        End If

    Next c



End Sub

This kind of works, we run into issues where the numbers in column B are greater than the average, it is the best I have for now.

Sub Button1_Click()
    Dim sh As Worksheet, ws As Worksheet
    Dim rng As Range, LstRw As Long
    Dim x As Long, y As Long, av As Long
    Dim sm As Long, r As Long, r1 As Long, i, L

    Set sh = Sheets("Sheet1")
    Set ws = Sheets("Sheet2")

    With sh
        LstRw = .Cells(.Rows.Count, "B").End(xlUp).Row
        Set rng = .Range("B2:B" & LstRw)
        .Range("C2:C" & LstRw).ClearContents

    End With

    x = Application.WorksheetFunction.CountA(ws.Range("A:A")) - 1
    y = Application.Sum(rng)
    av = Fix(y / x)
    k = 1

    r1 = sh.Cells(sh.Rows.Count, "C").End(xlUp).Row + 1
    If r1 = 2 Then r1 = 2
    L = 1
    For i = 2 To LstRw

        r1 = sh.Cells(sh.Rows.Count, "C").End(xlUp).Row + 1
        If r1 = 2 Then r1 = 2

        sm = sh.Cells(i, 2) + sm
        If sm > av Then
            k = k + 1
            r = sh.Cells(i, 2).Row - 1
            sh.Range("C" & r1 & ":C" & r).Value = ws.Cells(k, "A").Value
            sm = 0
            i = i - 1
        End If
        L = L + 1
        If L >= LstRw Then Exit Sub
    Next i



End Sub

Hi Som,

This works

Sub somX(): Dim r As Long, a As Long, c As Long, s As Long, Quota As Boolean
Dim w1 As Worksheet, w2 As Worksheet, t As Long, k As Long, N, Q
Set w1 = Sheets("Sheet1"): Set w2 = Sheets("Sheet2")
N = w2.UsedRange.Columns(1): w1.Cells(1, 3) = "Name"
Q = w1.UsedRange.Columns("A:D")
        s = WorksheetFunction.Sum(w1.Range("B2:B" & UBound(Q)))
                    k = 1 + s / (UBound(N) - 1)
GetQuota:
             For r = 2 To UBound(Q)
If Q(r, 2) > k And Q(r, 3) = "" Then Q(r, 3) = "Unassignable": s = s - Q(r, 2)
            Next r
    t = 1 + s / (UBound(N) - 1): Quota = IIf(t = k, True, False): k = t
            If Quota = False Then GoTo GetQuota
            
k = 0: t = t+1: r = 2: For a = 2 To UBound(N)
MakeAssignment:  'w1.UsedRange.Columns("A:D") = Q
                    
Do:     If r > UBound(Q) Then r = 2
        If Q(r, 3) <> "" Then r = r + 1: GoTo MakeAssignment
        If c + Q(r, 2) < t + 80 Then
        Q(r, 3) = N(a, 1): c = c + Q(r, 2): r = r + 1
        Else: r = r + 1: GoTo MakeAssignment
        End If
        Loop Until c >= t - 5 Or k + c >= s
        w2.Cells(a, 4) = c: Q(r - 1, 4) = c: k = k + c: c = 0
   
GetNext: If r > UBound(Q) Then r = 2
Next a
   w1.UsedRange.Columns("A:D") = Q: w1.Columns.AutoFit
End Sub

You're welcome and thanks for the rep!

But - it's not perfect