VBA code to find closest sum

[imran1059]

I need a VBA script tailored to Excel that will assist in my data analysis projects. It should prompt me to enter a target amount, then let me select a range of cells that contain various amounts. The code should find a combination within the selected range that makes the sum equal to or closest to the target amount. It could be more than the target amount or less than the target amount but it should be closest. It should then highlight the cells that make the sum that is closest to target amount. It should also ensure that only visible rows are to be considered. Hidden rows are not to be considered.

 

[eiloken]

I need a VBA script tailored to Excel that will assist in my data analysis projects. It should prompt me to enter a target amount, then let me select a range of cells that contain various amounts. The code should find a combination within the selected range that makes the sum equal to or closest to the target amount. It could be more than the target amount or less than the target amount but it should be closest. It should then highlight the cells that make the sum that is closest to target amount. It should also ensure that only visible rows are to be considered. Hidden rows are not to be considered.

try this:

Sub FindClosestValue()
    Dim myval As Double
    Dim findrange As Range, foundcell As Range
S0:
    myval = Application.InputBox("What value to find?")
    If myval = Empty Or Not IsNumeric(myval) Then
        MsgBox "Invalid input", vbCritical
        Exit Sub
    End If
    On Error GoTo iferr
S1:
    Set findrange = Application.InputBox(prompt:="What range to find?", Type:=8)
    If findrange Is Nothing Then Exit Sub
    findrange.Interior.Pattern = xlNone
    Set foundcell = ClosestValue(myval, findrange)
    If Not foundcell Is Nothing Then foundcell.Interior.Color = RGB(255, 255, 0)
iferr:
End Sub

Private Function ClosestValue(ByVal myval As Double, ByVal rng As Range) As Range
    Dim cll As Range
    Dim minSubtract As Double
    minSubtract = 9999
    For Each cll In rng
        If IsNumeric(cll.Value) Then
            If Abs(cll.Value - myval) < minSubtract Then
                minSubtract = Abs(cll.Value - myval)
                Set ClosestValue = cll
            ElseIf Abs(cll.Value - myval) = minSubtract Then
                If ClosestValue Is Nothing Then Set ClosestValue = cll Else Set ClosestValue = Union(ClosestValue, cll)
            End If
        End If
    Next cll
End Function