```
Sub SumValuesBasedOnUniqueItems()
Dim ws As Worksheet
Dim lastRow As Long
Dim cell As Range
Dim uniqueValues As New Collection
Dim dict As Object
Dim item As Variant
Dim key As Variant
Set ws = ThisWorkbook.Sheets("in")
lastRow = ws.Cells(ws.Rows.Count, "N").End(xlUp).Row
For Each cell In ws.Range("N2:N" & lastRow)
If Not IsEmpty(cell.Value) Then
On Error Resume Next
uniqueValues.Add cell.Value, CStr(cell.Value)
On Error GoTo 0
End If
Next cell
Set dict = CreateObject("Scripting.Dictionary")
For Each item In uniqueValues
Dim sumValue As Double
sumValue = 0
For Each cell In ws.Range("N2:N" & lastRow)
If cell.Value = item Then
sumValue = sumValue + cell.Offset(0, 1).Value ' Sum corresponding value in column O
End If
Next cell
If Not dict.Exists(item) Then
dict.Add item, sumValue
End If
Next item
Dim wsNew As Worksheet
Set wsNew = ThisWorkbook.Sheets.Add
wsNew.Name = "Temporary"
Z = 2
For Each key In dict.keys
Sheets("Temporary").Range("N" & Z).Value = key
Sheets("Temporary").Range("O" & Z).Value = dict(key)
Z = Z + 1
Next key
Dim wsNext As Worksheet
Dim lstRow As Long
Dim maxSum As Double
Dim maxRangeStart As Double
Dim maxRangeEnd As Double
Dim maxRangeElements As Long
Dim maxRange As Range
Set wsNext = ThisWorkbook.Sheets("Temporary")
lstRow = wsNext.Cells(wsNext.Rows.Count, "N").End(xlUp).Row
maxSum = 0
maxRangeStart = 0
maxRangeEnd = 0
maxRangeElements = 0
For i = 2 To lstRow
rangeStart = wsNext.Cells(i, "N").Value
For j = i To lstRow
rangeEnd = wsNext.Cells(j, "N").Value
currentSum = WorksheetFunction.Sum(wsNext.Range(wsNext.Cells(i, "O"), wsNext.Cells(j, "O")))
If currentSum > maxSum Then
maxSum = currentSum
maxRangeStart = rangeStart
maxRangeEnd = rangeEnd
Set maxRange = wsNext.Range(wsNext.Cells(i, "N"), wsNext.Cells(j, "N"))
End If
Next j
Next i
Dim topValue As Double
Dim bottomValue As Double
Dim bottomCell As Range
Dim topCell As Range
Dim cellT, cellB As Range
topValue = maxRange.Cells(1, 1).Value
bottomValue = maxRange.Cells(maxRange.Rows.Count, maxRange.Columns.Count).Value
For Each cellT In ws.Range("N2:N" & lastRow)
If cellT.Value = topValue Then
Set topCell = cellT
Exit For
End If
Next cellT
For Each cellB In ws.Range("N2:N" & lastRow)
If cellB.Value = bottomValue Then
Set bottomCell = cellB
Exit For
End If
Next cellB
Do While bottomCell.Value = bottomCell.Offset(1, 0).Value
Set bottomCell = bottomCell.Offset(1, 0)
Loop
maxRangeElements = bottomCell.Row - topCell.Row + 1
ws.Activate
ws.Range("N" & topCell.Row & ":N" & bottomCell.Row).Select
Application.DisplayAlerts = False
Sheets("Temporary").Delete
Application.DisplayAlerts = True
MsgBox "The SubArray in column N ranges from " & Format(maxRangeStart, "0.000") & " to " & Format(maxRangeEnd, "0.000") & " such that the Max Sum Value is " & Format(maxSum, "0.00") & " with " & maxRangeElements & " elements SubArray in column O.", vbInformation
End Sub
```