我必须根据生产率分解批量生产数据。我必须使用每周0.2批的最低速率，并将批量需求除以该速率。稍后我必须在几个星期内分发它。我已经能够做到这一点，但我无法将值限制在最大速率(0.4(内。这意味着，如果有重叠的数字，它们的总和不应超过0.4。如果发生这种情况，则我需要进一步分布值，以便没有单元格>0.4，总和与生产需求相同(在本例中为3(尝试1 的Excel网格截图
我的代码(屏幕截图中的标题仅供参考。真实文件没有标题(：
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
在我的第二次尝试中，我修改了代码，但在尝试2中得到了以下结果。基本上，我在第二次重试中所做的是在更新单元格后，我检查值是否大于0.4(最大速率(。如果是，那么我找到超过最大速率的额外量，用最大速率替换该值，并将额外值添加到上部单元格。然后对上面的单元格执行同样的操作(在分配值时，循环从下到上(。我本以为这会给我带来预期的结果(在屏幕截图1中(，但我得到了屏幕截图2中的输出。
第二次尝试中的代码：
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
生产率
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