Группировка в списки на основе сумм столбца - PullRequest
Новая
       35

Группировка в списки на основе сумм столбца

0 голосов
/ 13 марта 2019

Я надеюсь, что есть лучший способ сделать это. У меня есть некоторый код VBA, который сортирует элементы электронной таблицы по группам, где значения в столбце добавляют к x, где x - это значение, требуемое пользователем - скажем, 75. Используя рекурсию, если она превышает 75, она удаляет ближайшие значения это приводит к сумме, равной или равной 75. Аналогично, если она меньше 75, она будет циклически проходить и переставлять ряды так, чтобы группа достигала 75 или в пределах 0,5 меньше 75. Единственное ограничение заключается в том, что она не может пройти над целью и там может быть максимальное количество строк и минимальное количество строк.

Вот что у меня есть.

У меня есть эти функции, SortList, Staging, GetNearestValue, AddToGroup и RemoveFromGroup.

1007 * список сортировки * 

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 просто активируют строку ближайшей ячейки значения и либо вырезают и вставляют в диапазон группы, либо вырезают и вставляют ее вне диапазона группы.

Я приветствую предложения, так как у меня есть время для реорганизации кода для повышения производительности.

...