How to implement an advanced look up macro in excel?

[Katharina]

<tbody>
[TD="class: postcell"] How do I have to change the following macro code and formula which works for the data and question below(earlier data/question,column F) to make it suitable for Problemstatement (2) and (3) ?



(1)

Earlier data
Colums C,D,E,F
Row 1 4,10,40,F
Row 2 4,12,48,F
Row 3 4,14,56,F
Row 4 3,16,48,F
Row 5 1,18,18,F
Row 6 1,20,10,F
Row 7 0,22,0, 0 Intention of the column F

1. If Cx <> 0, Fx = Cx
2. If Cx = 0, Fx = the address of the cell in Column C that produces minimum of (C1 * D7 - E1, C2 * D7 - E2, ..., CN * D7 - EN) and is >0

Macro code and formula for column F

Public Function MinimumC()

<code>Dim rngCurrent As Range Set rngCurrent = Application.ThisCell Dim rngMin As Range Dim minimum As Long minimum = 100000000 Dim tmp As Long Dim rngC As Range Set rngC = ActiveSheet.Range("C1:C" & rngCurrent.Row - 1) For Each c In rngC.Cells If c.Value2 <> 0 Then tmp = c.Value2 * rngCurrent.Offset(0, -2).Value2 - c.Offset(0, 2) If tmp < minimum Then minimum = tmp Set rngMin = c End If End If Next c MinimumC = rngMin.Value2 </code></pre> End Function




Formula in F1 and copy down column F: =IF(C1<>0,C1,MinimumC())



(2)

How do I have to change the macro and formula to archieve the same in the following data format:


New data 1
Colums AZ,BA,BB,BC,BD,BE,BF,BG
Row 1 4,4,4,10,10,10,120,444
Row 2 4,4,4,12,12,12,144,444
Row 3 4,4,4,14,14,14,168,444
Row 4 3,3,3,16,16,16,144,333
Row 5 1,1,1,18,18,18,54,111
Row 6 1,1,1,20,20,20,60,111
Row 7 0,0,0,22,22,22,0, ???

Intention of the column BG

1. If(And(AZ>0;BA>0;BB>0);Concatenate(AZ;BA;BB))
2. otherwise, the adress cell of Concatenate (AZ;BA;BB), unequal to 000, to minimize the following difference (AZn*BCx+BAn*BDx+BBn*BEx)-BFn

(3)

How do I have to change the macro and formula from (1) to archieve the same in the following data format:


New data 2
Colums AZ,BA,BB,BC,BD,BE,BF,BG,BH,BI,BJ,BK,BL,BM,BN
Row 1 4,4,4,10,10,10,120,444,3,3,3,10,10,10,90,333
Row 2 4,4,4,12,12,12,144,444,3,3,3,12,12,12,108,333
Row 3 4,4,4,14,14,14,168,444,3,3,3,14,14,14,126,333
Row 4 3,3,3,16,16,16,144,333,3,3,3,16,16,16,144,333
Row 5 1,1,1,18,18,18,54,111,2,2,2,18,18,18,108,222
Row 6 1,1,1,20,20,20,60,111,1,1,1,20,20,20,60,111
Row 7 0,0,0,22,22,22,0,?,0,0,0,22,22,22,0, ?

Intention of the column BN

1. If(And(AZ>0;BA>0;BB>0;BH>0;BI>0;BJ>0);0
2. otherwise the adress of the cell either concatenate (AZ;BA;BB) or concatenate (BH;BI;BJ) to minimize (AZn*BCx+BAn*BDx+BBn*BEx)-BFn or (BHn*BKx+BIn*BLx+BJn*BMx)-BNn .In this case i need to find the adress of either concatenate (AZ;BA;BB) or concatenate (BH;BI;BJ) with the min difference and that cell of BN (concatenate) unequal to 000.

I appriciate the help, have been stuck with this for a while! Thanks so much!

[/TD]

</tbody>

 

[pbornemeier]

This looks a lot like a homework assignment, but I will enter this answer for (2).

No formula is needed.

Sub Part2()
    Dim lMinValue As Long
    Dim lCurrentValue As Long
    Dim lLastRow As Long
    Dim lX As Long
    Dim sOutput As String
    
    lLastRow = Cells(Rows.Count, "BF").End(xlUp).Row
    
    lMinValue = (Cells(1, "AZ") * Cells(1, "BC") + Cells(1, "BA") * Cells(1, "BD") + Cells(1, "BB") * Cells(1, "BE")) - Cells(1, "BF")
    For lX = 1 To lLastRow
        If Cells(lX, "AZ") & Cells(lX, "AZ") & Cells(lX, "AZ") = "000" Then
            lCurrentValue = (Cells(lX, "AZ") * Cells(lX, "BC") + Cells(lX, "BA") * Cells(lX, "BD") + Cells(lX, "BB") * Cells(lX, "BE")) - Cells(lX, "BF")
            If lCurrentValue < lMinValue Then lMinValue = lCurrentValue
        End If
    Next
    For lX = 1 To lLastRow
        If Cells(lX, "AZ") & Cells(lX, "AZ") & Cells(lX, "AZ") = "000" Then
            lCurrentValue = (Cells(lX, "AZ") * Cells(lX, "BC") + Cells(lX, "BA") * Cells(lX, "BD") + Cells(lX, "BB") * Cells(lX, "BE")) - Cells(lX, "BF")
            If lCurrentValue = lMinValue Then sOutput = sOutput & "BG" & lX & ", "
        End If
    Next
    sOutput = Left(sOutput, Len(sOutput) - 2)
    MsgBox "Minimum Value is " & lMinValue & vbLf & vbLf & "Row(s) contining min value: " & sOutput
End Sub

 

[Katharina]

@pbornemeier, thank you so much for providing some coding. Actually its the last part of coding to simulate a CCA auction (for my thesis), but I just wanted to explain it in the easiest way possible, hence i left out the context I really appriciate your help, as I have been stuck for a while and this code too somehow produces #Value, when instead it should be giving me the minimum. I probably made some errors somewhere and as I am very busy with work these next days, I hope you wont mind me maybe coming back to you by the end of the week ?! Again, thanks a lot!

 

[pbornemeier]

More questions are fine.

The code I sent earlier assumed no headers (which was foolish).
This version assumes the data starts in Row 2

Sub Part2()
    Dim lMinValue As Long
    Dim lCurrentValue As Long
    Dim lLastRow As Long
    Dim lX As Long
    Dim sOutput As String
    
    lLastRow = Cells(Rows.Count, "BF").End(xlUp).Row
    
    lMinValue = (Cells(2, "AZ") * Cells(2, "BC") + Cells(2, "BA") * Cells(2, "BD") + Cells(2, "BB") * Cells(2, "BE")) - Cells(2, "BF")
    For lX = 2 To lLastRow
        If Cells(lX, "AZ") & Cells(lX, "AZ") & Cells(lX, "AZ") = "000" Then
            lCurrentValue = (Cells(lX, "AZ") * Cells(lX, "BC") + Cells(lX, "BA") * Cells(lX, "BD") + Cells(lX, "BB") * Cells(lX, "BE")) - Cells(lX, "BF")
            If lCurrentValue < lMinValue Then lMinValue = lCurrentValue
        End If
    Next
    For lX = 2 To lLastRow
        If Cells(lX, "AZ") & Cells(lX, "AZ") & Cells(lX, "AZ") = "000" Then
            lCurrentValue = (Cells(lX, "AZ") * Cells(lX, "BC") + Cells(lX, "BA") * Cells(lX, "BD") + Cells(lX, "BB") * Cells(lX, "BE")) - Cells(lX, "BF")
            If lCurrentValue = lMinValue Then sOutput = sOutput & "BG" & lX & ", "
        End If
    Next
    sOutput = Left(sOutput, Len(sOutput) - 2)
    MsgBox "Minimum Value is " & lMinValue & vbLf & vbLf & "Row(s) contining min value: " & sOutput
End Sub

The #VALUE error may also be caused by values stored as text instead of numbers. You can correct that manually, or use the following code:

Sub EnsureNumbersInRowsBelowRow1()

    Dim lLastDataRow As Long
    Dim lLastDataColumn As Long
    Dim sColumnsToConvert As String
    Dim sFirstColumn As String
    Dim sLastColumn As String
    
    sColumnsToConvert = "AZ:BN"
    sFirstColumn = Split(sColumnsToConvert, ":")(0)
    sLastColumn = Split(sColumnsToConvert, ":")(1)
    
    lLastDataRow = Cells(Rows.Count, sFirstColumn).End(xlUp).Row
    lLastDataColumn = Cells(1, Columns.Count).End(xlToLeft).Column
    
    With Cells(1, lLastDataColumn + 1)
        .NumberFormat = 0
        .Value = 1
        .Copy
        Range(sFirstColumn & "2:" & sLastColumn & lLastDataRow).PasteSpecial _
            Paste:=xlPasteAll, Operation:=xlMultiply, SkipBlanks:=False, Transpose:=False
        .Value = vbNullString
    End With
    
End Sub

If the last cell of the last row really contains question marks, that could also cause the problem.

 

[Katharina]

thank you pbornemeier, i implemented your code with some changes, so it fits my real data and it works just fine. thanks, i appriciate the time and effort you put in hellping me.