Question

我希望有更好的方法来做到这一点。我有一些VBA代码，可将电子表格的项目分为几类，其中列中的值加到x，其中x是用户所需的值-说75。使用递归，如果超过75，则会删除最接近的值使得总和小于或等于75。同样，如果小于75，它将循环遍历并重新定位行，以便组达到75或小于75的0.5之内。唯一的限制是它不能越过目标并且在那里可以是最大行数和最小行数。

这是我到目前为止所拥有的。

我有这些功能，即SortList，Staging，GetNearestValue，AddToGroup和RemoveFromGroup。

排序列表

While TotalInventory > 0
    differential = maxTarget - Application.WorksheetFunction.Sum(Selection)
        If differential > 0 And differential > 0.6 And keepGroup.Rows.Count < listMax Then 'total is under limit but could potentially add to list before reaching max list size.
            findVal = GetNearestValue(differential, firstRow, lastRow)
            Call AddToGroup(keepGroup, cell, lastRow)
            Set keepGroup = AddToSelection(keepGroup, differential, lastRow)
            lastRow = lastRow + 1
            keepGroup.Select
            'differential = maxTarget - Application.WorksheetFunction.Sum(Selection)
        ElseIf differential < 0 Or keepGroup.Rows.Count > listMax Then     'if total exceeds desired maximum
            'Replace a row with one of lesser value
            findVal = GetNearestValue(differential, firstRow, lastRow)
            'Set keepGroup = Remove(keepGroup, findVal, lastRow)
            Call RemoveFromGroup(keepGroup, cell, lastRow)
            lastRow = keepGroup.Rows.Count + firstRow - 1
            keepGroup.Select
            'differential = maxTarget - Application.WorksheetFunction.Sum(Selection)
        Else    'The group is well calculated and ready to be allocated.
            Rows(lastRow + 1).Select
            Selection.Insert Shift:=xlDown

            keepGroup.Select
            Range(Cells(firstRow, keepGroup.Column), Cells(lastRow, keepGroup.Column)).EntireRow.Select
            Selection.Group
            Collapse keepGroup
            TotalInventory = TotalInventory - keepGroup.Rows.Count
            firstRow = lastRow + 2
            Cells(firstRow, "I").Activate
            Set keepGroup = staging(listMin)
            keepGroup.Select
            lastRow = Selection.Rows.Count + firstRow - 1
        End If
    Wend
enter code here

Staging（）：选择下一个可用行，并根据最小列表大小开始一个组。

Set Staging = Range(ActiveCell, ActiveCell.Offset(dm - 1, 0))

GetNearestValue

Private Function GetNearestValue(ByVal Value_To_Match As Double, firstRow As Long, lastRow As Long) As Double
    Dim cell As Range
    Dim valRange As Range
    Dim nearMatch As Double
    Application.ScreenUpdating = True
    'If difference is negative, search in the current selection. Otherwise get a new selection.
    If Value_To_Match > 0 Then
        Set valRange = Range(Cells(lastRow + 1, Selection.Column), Cells(ActiveSheet.Rows.Count - 1, Selection.Column))
        valRange.Select
    Else
        Set valRange = ActiveSheet.Range(Selection.Address)
        valRange.Select
    End If
    nearMatch = 0
    For Each cell In valRange
        If nearMatch <= cell.Value And cell < Abs(Value_To_Match) Then
'           cell.Activate
            nearMatch = cell
        End If
    Next
    'Debug.Print nearMatch
    GetNearestValue = nearMatch
End Function

AddToGroup和RemoveFromGroup只需激活最接近的值单元格的行，然后剪切并插入到组范围内或剪切并将其粘贴到组范围外即可。

欢迎您提出建议，因为我有一些时间来重构代码以提高性能。

根据列的总和分组为列表

0 个答案: