Re: find result - only for expert

Tech-Archive recommends: Fix windows errors by optimizing your registry

From: Ron Rosenfeld (ronrosenfeld_at_nospam.org)
Date: 11/15/04 

Date: Mon, 15 Nov 2004 17:15:25 -0500

On Mon, 15 Nov 2004 03:53:30 -0800, "Mark" <markgora@hotmail.com> wrote:

>Hi,
>I looking for best min_result in table below:
>
>Name Data Distance
>A 2.5 150
>B 6.5 250
>A 5.6 123
>A 9.5 121
>B 3.5 120
>B 4.8 150
>A 6.8 200
>
>min_result = sum of three min (the least) data (column 2)
>for Name in column 1.
>
>Important remark!!!
>Necessary condition: Distance (sum in column 3) of those
>three data must be > 500.
>Min_result can be higher result if nacessary condition
>can't be perform.
>Is there any way to resolve my problem?
>Any help will be appreciate.
>Regards
>Mark

Will this UDF do what you want? The arguments are the desired name (or cell
reference to that name) and the table (as a range or a named range).

=================================
Function foo(Name As String, tbl As Range) As Double
Dim NmDt()
Dim c As Range
Dim i As Integer, j As Integer
Dim col As Long, rw As Long
Const MinDistance As Double = 500

'Get Data and Distance for Name

col = tbl.Column
rw = tbl.Row

For i = rw To rw + tbl.Rows.Count - 1
    If Cells(i, col).Text = Name Then
        ReDim Preserve NmDt(1, j)
        NmDt(0, j) = Cells(i, col + 1) 'Data
        NmDt(1, j) = Cells(i, col + 2) 'Distance
        j = j + 1
    End If
Next i

'Sort array by distance

Call BubbleSort2(NmDt, 1)

For i = 0 To UBound(NmDt, 2) - 2
    If NmDt(1, i) + NmDt(1, i + 1) + NmDt(1, i + 2) > MinDistance Then
        foo = NmDt(0, i) + NmDt(0, i + 1) + NmDt(0, i + 2)
    End If
    If foo > 0 Then Exit For
Next i
    
End Function

 
Sub BubbleSort2(TempArray As Variant, Optional D As Variant) 'D is dimension to
sort on, 1-based
    
    Dim Temp As Variant
    Dim i As Integer, j As Integer
    Dim NoExchanges As Integer
    Dim NumDim As Long
    
    If IsMissing(D) Then D = 1
    D = D - 1
    
    'determine number of dimensions
    On Error GoTo ErrorNumDim
    For j = 1 To 60
        Temp = UBound(TempArray, j)
        If NumDim > 0 Then Exit For
    Next j
    On Error GoTo 0
    
    ' Loop until no more "exchanges" are made.
    Do
        NoExchanges = True

        ' Loop through each element in the array.
        For i = 0 To UBound(TempArray, 2) - 1

            ' If the element is greater than the element
            ' following it, exchange the two elements.
            If TempArray(D, i) > TempArray(D, i + 1) Then
                NoExchanges = False
                Temp = TempArray(D, i)
                TempArray(D, i) = TempArray(D, i + 1)
                TempArray(D, i + 1) = Temp
                    For j = 0 To NumDim - 1
                        If j <> D Then
                            Temp = TempArray(j, i)
                            TempArray(j, i) = TempArray(j, i + 1)
                            TempArray(j, i + 1) = Temp
                        End If
                    Next j
            End If
        Next i
    Loop While Not (NoExchanges)
Exit Sub

ErrorNumDim: If Err.Number = 9 Then
                NumDim = j - 1
                On Error GoTo 0
              End If
            Resume Next

End Sub

=============================

--ron

Relevant Pages