Sub UpdateScores()
Dim lr As Long
With ThisWorkbook.Sheets("Sheet1")
lr = .Cells(Rows.Count, "B").End(xlUp).Row + 1
With .Range(.Cells(lr, "B"), .Cells(lr, "K"))
' .FormulaR1C1 = "=IFERROR(IF(R4C=""N/A"","""",IF(AND(R3C=1,Win=""Yes""),(Players-1)*Bid,IF(AND(R3C=1,Win=""No""),(Players-1)*-Bid,IF(AND(R3C=0,Win=""No""),Bid,IF(AND(R3C=0,Win=""Yes""),Bid*-1,"""")))))+SUM(R[-1]C),"""")"
If lr = 5 Then
.FormulaR1C1 = "=IFERROR(IF(R2C=FALSE,"""",IF(AND(R3C=1,Win=""Yes""),(Players-1)*Bid,IF(AND(R3C=1,Win=""No""),(Players-1)*-Bid,IF(AND(R3C=0,Win=""No""),Bid,IF(AND(R3C=0,Win=""Yes""),Bid*-1,"""")))))+SUM(R[-1]C),"""")"
Else
' .FormulaR1C1 = "=IFERROR(IF(R2C=FALSE,R[-1]C,IF(AND(R3C=1,Win=""Yes""),(Players-1)*Bid,IF(AND(R3C=1,Win=""No""),(Players-1)*-Bid,IF(AND(R3C=0,Win=""No""),Bid,IF(AND(R3C=0,Win=""Yes""),Bid*-1,"""")))))+SUM(R[-1]C),"""")"
.FormulaR1C1 = "=IFERROR(IF(OR(R[-2]C="""",R[-2]C=""N/A""),"""",IF(R2C=FALSE,0,IF(AND(R3C=1,Win=""Yes""),(Players-1)*Bid,IF(AND(R3C=1,Win=""No""),(Players-1)*-Bid,IF(AND(R3C=0,Win=""No""),Bid,IF(AND(R3C=0,Win=""Yes""),Bid*-1,""""))))))+SUM(R[-1]C),"""")"
End If
.Value = .Value
End With
'===== BEGIN ADDED CODE =====
Dim c As Range, WinRng As Range, sh As Object
'set WinRng to winning cell (max?)
For Each c In .Cells(lr, 2).Resize(, 10)
'initialize
If WinRng Is Nothing Then Set WinRng = c
'store max value
If c > WinRng Then Set WinRng = c
Next c
'create new shape
Set sh = .Shapes.AddShape(msoShapeOval, _
WinRng.Left + (WinRng.Width / 4), _
WinRng.Top, _
WinRng.Width / 2, _
WinRng.Height)
With sh
.Name = lr & "-" & WinRng.Column & "_oval"
.Fill.Visible = msoFalse
With .Line
.Visible = msoTrue
.ForeColor.RGB = RGB(0, 255, 0)
.Transparency = 0
.Weight = 2.25
End With
End With
'===== END ADDED CODE =====
End With
End Sub
I added a section of code to your
Bookmarks