Find Highest Value based On Two Criteria, then Write to Cell

Question

I have a large csv/Excel invoice (UPS - not sure if that will matter). I validate and assign missing cost centers every week, using VBA to automate this process.

Usually it is no more complicated than, if x is this cell, then use y cost center.

Here is the problem:

We use a consolidated invoice which contains many different accounts. Sometimes the account is charged a service fee. If so, that service fee is applied to the cost center under the account which had the highest amount of charges.

Here is a stripped-down example.

We start with:

Because D8 says “Service Fee” I need B8 to equal the cost center with the highest amount of charges. In the case of Account1, CostCenter1 has the most charges at $17.00. For Account2, it will be CostCenter3.

The final product should look like:

I would show some code but I am at a loss of where to start.

Answer 1

For a formula in cell application,

=INDEX(A:C,MATCH(MAXIFS(C:C,A:A,"="& A8,C:C,"<>"&C8),C:C),2)

Just replace A8/C8 with the row it is being put into, or paste it into B8, and then copy/paste the cell into other rows. it's a quick fix and no programming, just using the built-in functionality of Excel.

Answer 2

I wrote a user-defined function that returns the CostCenter you need:

Public Function MaxCC()

Dim strAcc As String, strCC As String, dblChg As Double, lastrow As Long

strAcc = Application.Caller.Offset(, -1).Value2
lastrow = Application.Caller.Worksheet.Cells(Rows.Count, 1).End(xlUp).Row

Dim dictCC As New Scripting.Dictionary

Dim i As Long
For i = 2 To lastrow
    If Application.Caller.Worksheet.Cells(i, 1).Value2 = strAcc Then
        If i <> Application.Caller.Row Then strCC = Application.Caller.Worksheet.Cells(i, 2).Value2
        dblChg = Application.Caller.Worksheet.Cells(i, 3).Value2

        If Not dictCC.Exists(strCC) Then dictCC.Add strCC, 0

        dictCC(strCC) = dictCC(strCC) + dblChg
    End If
Next i

Dim strMaxCC As String, dblMaxCC As Double, varKey As Variant
dblMaxCC = 0
For Each varKey In dictCC.Keys
    If dictCC(varKey) > dblMaxCC Then
        strMaxCC = CStr(varKey)
        dblMaxCC = dictCC(varKey)
    End If
Next varKey

MaxCC = strMaxCC

End Function

This function uses a dictionary, just be sure to reference Microsoft Scripting Runtime as is described here.

You will be able to enter =MaxCC() as a formula into the empty cells you need filled and it will provide you with the correct CostCenter. Let me know if this works for you and if you have follow-up questions.

Answer 3

 function max2(arr,i) as double
  dim max as double 
  max=arr(i,0);
  for j=0 to ubound(arr,2)
    if arr(i,j)>max then max=arr(i,j)
   next
    max2=max
 end sub 

 sub test

  'build some kind of array structure for your pricing mess

  dim cc() as double
  redim cc(2,3)


   'just fill the structure somehow
   cc(0,0)=1'cc=cost center
   cc(0,1)=2
   cc(0,2)=3

   cc(1,0)=5
   cc(1,1)=1
   cc(1,2)=7

   'get the maximum profit to be able to buy a new Porsche      

  debug.print max2(cc,0)  

  debug.print max2(cc,1)

 'if we need a Ferrari

  result=max2(cc,0)  
  if max2(cc,1) > result then result =max2(cc,1)

  ' or just add a modified max sub with just one dimension
  'or fill a virtual cost center array with the results so far... and run the 
  'max2 fucntion on that  

end sub

Answer 4

This solution uses a class, I used late binding on the dictionaries, if you want early binding add the reference and set variable = New Dictionary

Class Code:

Option Explicit

Private pCenterdict As Object

Public Sub Load_Data(center As String, cost As Double)
    If Not pCenterdict.Exists(center) Then
        pCenterdict.Add center, cost
    Else
        pCenterdict(center) = pCenterdict(center) + cost
    End If
End Sub

Public Sub initialize()
    Set pCenterdict = CreateObject("Scripting.Dictionary")
End Sub

Public Function return_highest() As String
    Dim key As Variant
    Dim highestkey As String
    Dim highestval As Double

    highestval = 0
    For Each key In pCenterdict.Keys()
        If pCenterdict(key) > highestval Then
            highestval = pCenterdict(key)
            highestkey = key
        End If
    Next key
    return_highest = highestkey
End Function

Main code:

Sub test()
    Dim lr As Long
    Dim i As Long

    Dim clsdict As Object
    Dim clsobj As Object

    Set clsdict = CreateObject("Scripting.Dictionary")

    With ActiveWorkbook.Sheets("Sheet1") ' Change this to whatever the sheet name is
    lr = .Cells(.rows.count, 1).End(xlUp).row

    For i = 2 To lr
        If Not .Cells(i, 4).value = "Service Fee" Then
            If Not clsdict.Exists(.Cells(i, 1).value) Then
                Set clsobj = New Cls_SO 'Create instance, If you name your class something else change this to New YourClassNameHere
                clsobj.initialize 'Create Dictionary
                clsobj.Load_Data .Cells(i, 2).value, .Cells(i, 3).value 'Load Values
                clsdict.Add .Cells(i, 1).value, clsobj
            Else
                clsdict(.Cells(i, 1).value).Load_Data .Cells(i, 2).value, .Cells(i, 3).value 'Load Values
            End If
        Else
            .Cells(i, 2).value = clsdict(.Cells(i, 1).value).return_highest 'Get Highest
        End If
    Next
    End With



End Sub