如何在 VBA 中的范围内均匀分布已知数字

如何解决如何在 VBA 中的范围内均匀分布已知数字

我在这里遇到了一个问题，我一直在尝试使用 VBA 在一个范围内均匀分布一个已知数字。问题是我需要找到使该范围内的数字尽可能相等的方法彼此，你能帮帮我吗？或提出想法？

数据集如下

已知数字由“TV Comodin”行以红色给出，这是我的尝试：

    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

基本上，我的代码找到“TV Comodin”行以获取循环将在其列的每一行中 1 x 1 添加的次数，

抱歉，我对 VBA 有点陌生，顺便说一下。

解决方法

这是一种方法。找出范围内最小的数字：加一。重复直到完成（例如）55 次。

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