Breaking down values in one cloumn according to max and min production rate?

user_3601100 0
Viewed 36

I have to break batch production data as per production rate. I have to use a minimum rate of 0.2 batches per week and divide the batch demand by this rate. Later I have to distribute it across weeks. I have been able to do this, but I am unable to cap the values within max rate (0.4). What this means that if there are overlapping numbers than their sum should not exceed 0.4. If this happens then I need to further distribute the values so that no cell is >0.4 and total sum is the same as production demand (in this case 3) screenshot of Excel grid for attempt 1

My code (the headers in the screenshot is for information. Real file has no headers):

Dim row1, row2, weeks As Integer

Dim rate As Double

Worksheets("trial 1").Activate

Range("D:D").Clear

For row1 = 1 To 15
    If Range("C" & row1).Value = "" Then
    
        GoTo over
    
    ElseIf Range("C" & row1).Value = 1 Then
        
        rate = Range("I9").Value
        
    Else
    
        rate = Range("J9").Value
    End If
    

weeks = Application.WorksheetFunction.RoundUp _
(Range("C" & row1).Value / rate, 0)

    For row2 = row1 To row1 - weeks + 1 Step -1
    
        Cells(row2, 4).Value = Cells(row2, 4).Value + rate
    
    Next row2

over:
Next row1

End Sub

In my 2nd attempt I modified the code but got the below result result for attempt 2 Basically what I did in the 2nd attempt is after updating the cell I check if the value is greater than 0.4 (max rate). If it is, then I find the extra amount over the max rate, replace the value with max rate, and add the extra value to the upper cell. Then do the same for the upper cell (my loop goes from bottom to top while distributing the values). I was expecting that this would give me the expected result (in screenshot 1) but instead I got the output seen in screenshot 2.

Code in 2nd attempt:

Sub trial2()

Dim row1, row2, row3, weeks As Integer
Dim rate, extra As Double

Worksheets("trial 2").Activate
Range("D:D").Clear

For row1 = 1 To 12
    If Range("C" & row1).Value = "" Then
    
        GoTo over
    
    ElseIf Range("C" & row1).Value = 1 Then
        
        rate = Range("I9").Value
        
    Else
    
        rate = Range("J9").Value
    End If
    

weeks = Application.WorksheetFunction.RoundUp _
(Range("C" & row1).Value / rate, 0)


row2 = row1

row3 = row1 - weeks + 1

    Do
        
        Cells(row2, 4).Value = Cells(row2, 4).Value + rate + extra
        
        If Cells(row2, 4).Value > Range("J9").Value Then
            rate = Range("J9").Value
            extra = Cells(row2, 4).Value - Range("J9").Value
            Cells(row2, 4).Value = Range("J9").Value
                
                If extra > 0 Then
                row3 = row3 - 1
                End If
        
        End If
        row2 = row2 - 1
              
    Loop Until row2 <= row3
    
    extra = 0

over:
Next row1

End Sub
vba excel
1 Answers

Production Rate

Option Explicit

Sub RateProduction()
    
    Const wsName As String = "Trial 1"
    Const sFirstCellAddress As String = "C1"
    Const dFirstCellAddress As String = "D1"
    Const dNumberFormat As String = "0.00"
    Const MaxAddress As String = "I9"
    Const MinAddress As String = "J9"
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Reference the source range.

    Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)

    Dim srg As Range

    With ws.Range(sFirstCellAddress)
        Dim lCell As Range: Set lCell = .Resize(ws.Rows.Count - .Row + 1) _
            .Find("*", , xlFormulas, , , xlPrevious)
        If lCell Is Nothing Then Exit Sub
        Set srg = .Resize(lCell.Row - .Row + 1)
    End With
    
    ' Retrieve min and max.
    Dim MaxRate As Double: MaxRate = ws.Range(MaxAddress).Value
    Dim MinRate As Double: MinRate = ws.Range(MinAddress).Value
    
    ' Calculate.
    
    Dim TotMin As Double: TotMin = Application.Sum(srg) - MinRate
    Dim tCount As Long: tCount = Int(TotMin / MaxRate)
    Dim rCount As Long: rCount = tCount + 1
    Dim tMin As Double: tMin = TotMin + MinRate - tCount * MaxRate
    
    Dim t1 As Double
    Dim t2 As Double
    Dim CalcMin As Boolean
    
    Select Case tMin
    Case Is > MaxRate
        If tMin - MaxRate >= MinRate Then
            t1 = MaxRate
            t2 = tMin - MaxRate
        Else
            CalcMin = True
        End If
    Case MaxRate
        t1 = MaxRate
        t2 = 0
    Case Else ' Case Is < MaxRate
        CalcMin = True
    End Select
    
    If CalcMin Then
        If tMin - MinRate >= MinRate Then
            t1 = tMin - MinRate
            t2 = MinRate
        Else ' If tMin - MinRate < MinRate Then
            t1 = tMin
            t2 = 0
        End If
    End If
    
    ' Write the results to an array.
    
    If t2 <> 0 Then rCount = rCount + 1
    Dim Data() As Double: ReDim Data(1 To rCount, 1 To 1)
    
    Dim r As Long
    
    For r = 1 To tCount
        Data(r, 1) = MaxRate
    Next r
    
    Data(r, 1) = t1
    If t2 <> 0 Then Data(r + 1, 1) = t2
    
    ' Write the results from the array to the destination range.
    With ws.Range(dFirstCellAddress).Resize(rCount)
        ' Write the results.
        .Value = Data
        ' Apply formatting.
        .NumberFormat = dNumberFormat
        ' Clear below.
        .Resize(ws.Rows.Count - .Row - rCount + 1).Offset(rCount).Clear
    End With
    
End Sub
user_98140690
Related