VBA在范围内动态分配值

问题描述 投票:0回答:1

我正在尝试建立以前根据排名分配值的工作。下面的代码有效,但假设总有三行排名。

示例图像和代码

enter image description here

Sub distrib()

Set R1 = ActiveSheet.UsedRange     
M = 62

For i = 2 To UBound(T1)
    If T1(i, 2) > 0 Then
        V = T1(i, 2)
        If V <= M Then
            For j = i To i + 2
                If T1(j, 1) = 1 Then
                    T1(j, 3) = V
                Else
                    T1(j, 3) = 0
                End If
            Next j
        Else
            A = M
            V = V - M
            If V > M Then
                B = M
                V = V - M
                If V > M Then
                    C = M
                Else
                    C = V
                End If
            Else
                B = V
                C = 0
            End If
            For j = i To i + 2
                Select Case T1(j, 1)
                    Case Is = 1
                        T1(j, 3) = A
                    Case Is = 2
                        T1(j, 3) = B
                    Case Is = 3
                        T1(j, 3) = C
                End Select
            Next j
        End If
    End If 
Next i

For i = 2 To UBound(T1)
    Cells(i, 3) = T1(i, 3) 
Next i

End Sub

理想的结果:我需要一种方法来使分布动态响应行高或loop值。

逻辑应该确定范围有多宽(即loop值)并基于秩在范围内分布值,每个单元的最大值不超过62。见下图

非常感谢您的帮助,并乐意提供澄清。

enter image description here

excel vba excel-vba dynamic
1个回答
1
投票

如果列D中的循环值已经存在,我认为这将起作用。

Sub x()

Dim r As Range, rDist As Range, n As Variant, i As Long, wf As WorksheetFunction

Const nMax As Long = 62
Set wf = WorksheetFunction

For Each r In Range("D2", Range("D" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants)
    Set rDist = r.Offset(, -3).Resize(r.Value, 3)
    For i = 1 To r
        n = Application.Match(i, rDist.Columns(1), 0)
        If IsNumeric(n) Then
            If wf.Max(rDist.Columns(2)) - wf.Sum(rDist.Columns(3)) < nMax Then
                rDist(n, 3) = wf.Max(rDist.Columns(2)) - wf.Sum(rDist.Columns(3))
                Exit For
            Else
                rDist(n, 3) = nMax
            End If
        End If
    Next i
Next r

Columns(3).SpecialCells(xlCellTypeBlanks).Value = 0

End Sub
© www.soinside.com 2019 - 2024. All rights reserved.