$ Total a Quantity from Lowest to Highest Price

Hello everyone. I am really stumped on this problem and I am not even sure if a macro is needed to solve it. Sure looks like it though.

Please see attached.

In sheet Problem 1, there is a Current Stock table and a Sale table. The highlighted cells, J6:J9 will initially be empty and this is what I would like to populate.

The Total in column J for each Item should be a dollar amount such that it equals the sum of [the lowest price of that item in the Current Stock table times the available quantity at that price]

Therefore, item A in cell H6 with a quantity of 3 will have a dollar total (2 x $0 + 1 x $1). Since there were only 2 units at $0 each in the current stock table, there is no available stock at this price anymore, while there remains 6 left of A priced at $1.

Thus, item A in cell H7 with a quantity of 2 will have a dollar total of (2 x $ 1). Now there are only 4 left of item A priced at $1 each in the Current Stock table.

As such, item A in cell H8 with a quantity of 9 will have a dollar total of (4 x $1 + 2 x $4 + 3 x $5).

And so on and so forth for the rest of the items.


In sheet Problem 2, the requirement is similar, but this time, there is a Type condition in the sale, which restricts the pricing of the item at the specified type.



I hope that made sense. I am having a really hard time figuring out how to do this. Any help/guidance would be very much appreciated.

Hi,

Probably this is what you need :

Sub Problem1()
  Dim rng As Range, cell As Range, arrData, arrJob, isAnyChanges As Boolean, i As Long, j As Long

  Sheets("Problem 1").Select

  Set rng = Range(Range("A6"), Range("A6").End(xlDown)).Resize(, 6)
  For Each cell In rng.Columns(6).Cells: cell.Value = cell.Row: Next cell
  rng.Sort key1:=rng.Columns(1), key2:=rng.Columns(4)
  arrData = rng.Value
  rng.Sort key1:=rng.Columns(6)
  rng.Columns(6).ClearContents
  'Range("A15").Resize(UBound(arrData, 1), UBound(arrData, 2)) = arrData

  Set rng = Range(Range("H6"), Range("H6").End(xlDown)).Resize(, 5)
  arrJob = rng.Value
  For i = 1 To UBound(arrJob, 1)
      arrJob(i, 3) = 0
      arrJob(i, 4) = ""
      arrJob(i, 5) = arrJob(i, 2)
      isAnyChanges = True

      While (arrJob(i, 5) > 0) And isAnyChanges
        isAnyChanges = False
        For j = 1 To UBound(arrData, 1)
            If arrData(j, 1) = arrJob(i, 1) Then
               Select Case arrData(j, 3)
                 Case 0
                   'Rem Skip
                 Case Is < arrJob(i, 5)
                   arrJob(i, 3) = arrJob(i, 3) + (arrData(j, 3) * arrData(j, 4))
                   arrJob(i, 4) = arrJob(i, 4) & "+" & arrData(j, 3) & "@" & arrData(j, 4) & Space(1)
                   arrJob(i, 5) = arrJob(i, 5) - arrData(j, 3)
                   arrData(j, 3) = 0
                   isAnyChanges = True
                 Case Is >= arrJob(i, 5)
                   arrJob(i, 3) = arrJob(i, 3) + (arrJob(i, 5) * arrData(j, 4))
                   arrJob(i, 4) = arrJob(i, 4) & "+" & arrJob(i, 5) & "@" & arrData(j, 4) & Space(1)
                   arrData(j, 3) = arrData(j, 3) - arrJob(i, 5)
                   arrJob(i, 5) = 0
                   isAnyChanges = True
                   Exit For
               End Select
            End If
        Next j
      Wend
      arrJob(i, 4) = "'=" & Trim(Mid(arrJob(i, 4), 2))
      If arrJob(i, 5) > 0 Then MsgBox "Not enough stock for item : " & arrJob(i, 1)
  Next i
  'Range("H15").Resize(UBound(arrJob, 1), UBound(arrJob, 2)) = arrJob
  rng.Resize(, 4) = arrJob
End Sub
Sub Problem2()
  Dim rng As Range, cell As Range, arrData, arrJob, isAnyChanges As Boolean, i As Long, j As Long

  Sheets("Problem 2").Select

  Set rng = Range(Range("A6"), Range("A6").End(xlDown)).Resize(, 6)
  For Each cell In rng.Columns(6).Cells: cell.Value = cell.Row: Next cell
  rng.Sort key1:=rng.Columns(1), key2:=rng.Columns(4)
  arrData = rng.Value
  rng.Sort key1:=rng.Columns(6)
  rng.Columns(6).ClearContents
  'Range("A15").Resize(UBound(arrData, 1), UBound(arrData, 2)) = arrData

  Set rng = Range(Range("H6"), Range("H6").End(xlDown)).Resize(, 6)
  arrJob = rng.Value

  For i = 1 To UBound(arrJob, 1)
      arrJob(i, 4) = 0
      arrJob(i, 5) = ""
      arrJob(i, 6) = arrJob(i, 3)
      isAnyChanges = True

      While (arrJob(i, 6) > 0) And isAnyChanges
        isAnyChanges = False
        For j = 1 To UBound(arrData, 1)
            If (arrData(j, 1) = arrJob(i, 1)) And (arrData(j, 2) = arrJob(i, 2)) Then
               Select Case arrData(j, 3)
                 Case 0
                   'Rem Skip
                 Case Is < arrJob(i, 6)
                   arrJob(i, 4) = arrJob(i, 4) + (arrData(j, 3) * arrData(j, 4))
                   arrJob(i, 5) = arrJob(i, 5) & "+" & arrData(j, 3) & "@" & arrData(j, 4) & Space(1)
                   arrJob(i, 6) = arrJob(i, 6) - arrData(j, 3)
                   arrData(j, 3) = 0
                   isAnyChanges = True
                 Case Is >= arrJob(i, 6)
                   arrJob(i, 4) = arrJob(i, 4) + (arrJob(i, 6) * arrData(j, 4))
                   arrJob(i, 5) = arrJob(i, 5) & "+" & arrJob(i, 6) & "@" & arrData(j, 4) & Space(1)
                   arrData(j, 3) = arrData(j, 3) - arrJob(i, 6)
                   arrJob(i, 6) = 0
                   isAnyChanges = True
                   Exit For
               End Select
            End If
        Next j
      Wend
      arrJob(i, 5) = "'=" & Trim(Mid(arrJob(i, 5), 2))
      If arrJob(i, 6) > 0 Then MsgBox "Not enough stock for item : " & arrJob(i, 1) & " ,type : " & arrJob(i, 2)
  Next i
  'Range("H15").Resize(UBound(arrJob, 1), UBound(arrJob, 2)) = arrJob
  rng.Resize(, 5) = arrJob
End Sub

Regards

You are welcome uberathlete, thanks for the feedback.


Regards