[Solved] Find Subarray Such That the Corresponding Subarray Has Max Sum Value

[Boy282828]

Dear Lutfor,



About the last VBA Code you provide to find the SubArray Range in Column N

such that the Corresponding SubArray Range Sum is Maximum in Column O,

I found out that for the same values in Column N, it will ignore the Negative

Values in Column N to get the Max Value SubArray in Column O. For example,

enclosed the 2023NBADEMY.xlsm File, Title “RDF(H-V)” in Column N, Title

“MDOG 4W” in Column O, running the VBA Code it shows that in RDF(H-V)

From 1.700 to 7.300 it will get the Max Sum +4777.48, but it ignores the same

6 elements of 1.700 above it which all gives -100 values in Column O, it also

ignores 1 element of the same 7.300 below it which gives -100 in Column O.

So the Max Sum should be +4777.48 – 7*100 = +4077.48 which is not the

true Max Sum because I just guess a range in Column N from -8.20 to +7.30,

the corresponding Max Sum in Column O is +4554.48 larger than +4077.48.

I am sure my guess is wrong, it is just guessing, there should be a range that

gives the true Max Sum greater than my guess Sum of +4554.48. Could you

modify the VBA Code which include ALL range elements to give the real true

Max Sum? To clear and simplify things, could you in the result statement just

mention in Column N or in Column O, don’t mention the Title names since I

may use different Title names in the future. Thanks,



Boy282828 4/26/2024

 

[Boy282828]

I try to upload the excel file named 2023NBADEMYEXCEL.xlsm, it only has one worksheet named "MLDOG RAW" with only 2 real number arrays in Column N and Column O, but it refuse to accept because "The File is too Big", I got confused. I hope you can my point without attaching Excel File.
Thanks,

Boy282828 4/26/2024

 

[Lutfor Rahman Shimanto]

I try to upload the excel file named 2023NBADEMYEXCEL.xlsm, it only has one worksheet named "MLDOG RAW" with only 2 real number arrays in Column N and Column O, but it refuse to accept because "The File is too Big", I got confused. I hope you can my point without attaching Excel File.
Thanks,

Boy282828 4/26/2024

Dear

Thanks for sharing your findings regarding the previously provided VBA sub-procedure. You mentioned that for the same values in Column N, it will ignore the Negative Values in Column N to get the Max Value SubArray in Column O. You want to modify the VBA Code, which includes ALL range elements, to give the true Max Sum. Besides, you want to generalize the report message by displaying columns N and O instead of their titles.

I have tried to modify the existing VBA code (previously given) as per your requirements, but I encountered difficulties when testing. It would be great if you could share the data in columns N and O so that I can test it. To do so, you can try sharing the CSV file instead of the Excel file. You can also share the file via a Google Drive or OneDrive link, from which I can download the file.

However, I have worked on displaying the reports you mentioned.

​

Excel VBA Sub-procedure:

Sub AdvancedFindMaxSubArraySum()

    Dim ws As Worksheet
    Dim lastRow As Long
    Dim maxSum As Double
    Dim maxRangeStart As Double
    Dim maxRangeEnd As Double
    Dim maxRangeElements As Long
    Dim maxRange As Range
    
    Set ws = ThisWorkbook.Sheets("SUMMARY")
    
    lastRow = ws.Cells(ws.Rows.Count, "N").End(xlUp).Row
    
    maxSum = 0
    maxRangeStart = 0
    maxRangeEnd = 0
    maxRangeElements = 0
    
    For i = 2 To lastRow

        rangeStart = ws.Cells(i, "N").Value
        
        For j = i To lastRow

            rangeEnd = ws.Cells(j, "N").Value
            
            currentSum = WorksheetFunction.Sum(ws.Range(ws.Cells(i, "O"), ws.Cells(j, "O")))
            
            If currentSum > maxSum Then
                maxSum = currentSum
                maxRangeStart = rangeStart
                maxRangeEnd = rangeEnd
                maxRangeElements = j - i + 1

                Set maxRange = ws.Range(ws.Cells(i, "N"), ws.Cells(j, "N"))
            End If
        Next j
    Next i
    
    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."
    
    If Not maxRange Is Nothing Then
        maxRange.Select
    End If

End Sub

So, try to share the file with me. Hopefully, you want to display the Results and Reports within the MsgBox, as shown in the image above.

Regards
Lutfor Rahman Shimanto
Excel & VBA Developer
ExcelDemy

 

[Boy282828]

Dear Lutfor,



Per your instructions I saved the Excel File named “2023NBADEMYEXCEL” as .csv File,

But Microsoft said if I save in .csv File, some features may be lost. I hope you can see it and

edit the VBA Code. Thanks,

2023NBADEMYEXCEL.csv

Boy282828 4/30/2024

 

[Lutfor Rahman Shimanto]

Dear Lutfor,



Per your instructions I saved the Excel File named “2023NBADEMYEXCEL” as .csv File,

But Microsoft said if I save in .csv File, some features may be lost. I hope you can see it and

edit the VBA Code. Thanks,

2023NBADEMYEXCEL.csv

Boy282828 4/30/2024

Dear, Please share the Excel file through OneDrive, as I cannot open it.

​

Regards
Lutfor Rahman Shimanto
ExcelDemy

 

[Boy282828]

"C:\Users\chem8\OneDrive\Documents\2023NBADEMYEXCEL.csv"

 

[Boy282828]

2023NBADEMYEXCEL.csv

 

[Lutfor Rahman Shimanto]

Dear Lutfor,



About the last VBA Code you provide to find the SubArray Range in Column N

such that the Corresponding SubArray Range Sum is Maximum in Column O,

I found out that for the same values in Column N, it will ignore the Negative

Values in Column N to get the Max Value SubArray in Column O. For example,

enclosed the 2023NBADEMY.xlsm File, Title “RDF(H-V)” in Column N, Title

“MDOG 4W” in Column O, running the VBA Code it shows that in RDF(H-V)

From 1.700 to 7.300 it will get the Max Sum +4777.48, but it ignores the same

6 elements of 1.700 above it which all gives -100 values in Column O, it also

ignores 1 element of the same 7.300 below it which gives -100 in Column O.

So the Max Sum should be +4777.48 – 7*100 = +4077.48 which is not the

true Max Sum because I just guess a range in Column N from -8.20 to +7.30,

the corresponding Max Sum in Column O is +4554.48 larger than +4077.48.

I am sure my guess is wrong, it is just guessing, there should be a range that

gives the true Max Sum greater than my guess Sum of +4554.48. Could you

modify the VBA Code which include ALL range elements to give the real true

Max Sum? To clear and simplify things, could you in the result statement just

mention in Column N or in Column O, don’t mention the Title names since I

may use different Title names in the future. Thanks,



Boy282828 4/26/2024

Dear Dawson Chuang

Thanks for your patience! I was able to get the data from your shared link. I have reviewed your requirements and found that you were right. So, I improved the existing algorithm and developed a new sub-procedure to fulfil your goal.

SOLUTION Overview:

​

Excel VBA Sub-procedure:

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

The previous algorithm worked perfectly on the data for unique values. But your current dataset has multiple non-contiguous cells that contain the same value in column N. So, the enhanced algorithm first finds the unique values and also calculates the sum for each. Later, it adds a temporary sheet and stores those values (which will be deleted at the end of all tasks). Finally, with the help of the previous algorithm, I was able to find the true Max-Sum.

I hope you have found an ultimate solution to Find a Subarray such that the Corresponding Subarray Has a Max-Sum Value. I have attached the solution workbook for better understanding; good luck.

Regards
Lutfor Rahman Shimanto
Excel & VBA Developer
ExcelDemy

 

[Boy282828]

Dear Lutfor,
Great! It works perfect! Thanks,
Boy282828 5/5/2024

 

[Lutfor Rahman Shimanto]

Dear Lutfor,
Great! It works perfect! Thanks,
Boy282828 5/5/2024

Dear Dawson Chuang, you are most welcome. We are glad that the solution worked perfectly.

Regards
ExcelDemy