excelvba

Distribute a number across a range so the numbers in the range are as equal as possible to each other


I am trying to distribute a number across a range.

I need the numbers in the range to be as equal as possible to each other.

The data set is as follows:
enter image description here

The known number is given by "TV Comodin" Row in color Red, and here is my try:

Sub Prueba()

    Columns("A:A").Select
    Set Cell = Selection.Find(What:="TV Comodín", After:=ActiveCell, LookIn:=xlFormulas, _
      LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
      MatchCase:=False, SearchFormat:=False)
    ActiveCell = Cell
    Cell.Select
        
    comodin = ActiveCell.Offset(0, 1).Value2

    Range("A2").Select
    Firstrow = ActiveCell.Row
    Selection.End(xlDown).Select
    Lastrow = ActiveCell.Row

    j = comodin 
    While (j > 0)
        For i = 2 To Lastrow
            Range("B2").Select
            Range("B" & i) = Range("B" & i).Value + 1
            If j > 0 Then j = j - 1
            If j = 0 Then Exit For
        Next
    Wend
              
End Sub

My code finds the "TV Comodin" row to get the number of times that the loop will add 1 by 1 in every row of its column.


Solution

  • Here's one approach. Find the smallest number in the range: add one. Repeat until you've done that (eg) 55 times.

    Sub Prueba()
        Dim f As Range, ws As Worksheet, comodin As Long, rng As Range, m, mn
        
        Set ws = ActiveSheet
        
        Set rng = ws.Range("A2", ws.Range("A2").End(xlDown)).Offset(0, 1)
        
        Set f = ws.Columns("A").Find(What:="TV Comodín", LookIn:=xlFormulas, _
                                     LookAt:=xlWhole, MatchCase:=False)
       
        If Not f Is Nothing Then
            rng.Value = ws.Evaluate("=" & rng.Address() & "*1") 'fill empty cells with zeros
            comodin = f.Offset(0, 1).Value
            Do While comodin > 0
                mn = Application.Min(rng)
                If mn >= 100 Then Exit Do ' exit when no values are <100 
                m = Application.Match(mn, rng, 0)
                rng.Cells(m).Value = rng.Cells(m).Value + 1
                comodin = comodin - 1
            Loop
        Else
            MsgBox "not found!"
        End If
    End Sub