find result - only for expert
 

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

find result - only for expert
 

Can you sort your data on the "Data" column ascending? Then you take the
first 3 sequential cells that sum to greater than 500.

--
Regards,
Tom Ogilvy



"Mark" wrote in message
...
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

find result - only for expert
 

Tom/Mark,

The problem appears to be that this min_result should be calculated
*for each* name in Column A. The problem isn't exactly clear to me on
one point however:

If the condition sum(distance)500 isn't met, there are 3 possible
outcomes:

1. take one extra row until the total 500 (so more than 3 rows)
2. drop the row with the smallest value in Distance and take the next
that has a higher value in Distance (so the amount of rows remains 3)
3. drop the row with the highest value in Data (from the 3 lowest) and
find the nearest lowest Data row

Which is it?

find result - only for expert
 

On Mon, 15 Nov 2004 03:53:30 -0800, "Mark" 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

find result - only for expert
 

The comment below in the UDF:

'Sort array by distance

Should read:

'Sort array by Data

Obviously, makes no difference in how it functions.

--ron



On Mon, 15 Nov 2004 17:15:25 -0500, Ron Rosenfeld
wrote:

On Mon, 15 Nov 2004 03:53:30 -0800, "Mark" 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

--ron

find result - only for expert
 

To enter the UDF that I posted:

<alt<F11 opens the Visual Basic Editor.
Ensure your project is highlighted in the Project Explorer Window, then
Insert/Module.

Paste the code below into the window that opens.

To USE the UDF, in some cell enter a formula:

=foo(A1,tbl) where A1 contains the Name, and tbl is the range consisting of the
Table.


--ron


On Mon, 15 Nov 2004 03:53:30 -0800, "Mark" 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

--ron

find result - only for expert
 

Hi Ron!

You code is very smart i've managed and appeared correct
result.
I've one more question:
My table has thousands rows and tens columns.
How to show in another sheet data perform neccesary
condition for all Name in column)? The form data could be
e.g.:

Min_result for A = 4.8, Distance = 530
Name Data Distance Data_in_Column7 (additionally)
A 1.2 150 Xrt
A 2.2 280 Yur
A 1.4 100 Opu

'two rows below is next Name perform condition

Min_result for B = 6,2, Distance = 620
Name Data Distance Data_in_Column7 (additionally)
A 2.2 240 Pok
A 2.4 280 Utr
A 1.6 100 Opu

etc.. next Name in column 1


Thanks for your professional help!
Best Regards
Mark




-----Original Message-----
To enter the UDF that I posted:

<alt<F11 opens the Visual Basic Editor.
Ensure your project is highlighted in the Project
Explorer Window, then
Insert/Module.

Paste the code below into the window that opens.

To USE the UDF, in some cell enter a formula:

=foo(A1,tbl) where A1 contains the Name, and tbl is the
range consisting of the
Table.


--ron


On Mon, 15 Nov 2004 03:53:30 -0800, "Mark"
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

--ron
.

find result - only for expert
 

On Mon, 15 Nov 2004 23:00:42 -0800, "Mark" wrote:

Hi Ron!

You code is very smart i've managed and appeared correct
result.
I've one more question:
My table has thousands rows and tens columns.
How to show in another sheet data perform neccesary
condition for all Name in column)? The form data could be
e.g.:

Min_result for A = 4.8, Distance = 530
Name Data Distance Data_in_Column7 (additionally)
A 1.2 150 Xrt
A 2.2 280 Yur
A 1.4 100 Opu

'two rows below is next Name perform condition

Min_result for B = 6,2, Distance = 620
Name Data Distance Data_in_Column7 (additionally)
A 2.2 240 Pok
A 2.4 280 Utr
A 1.6 100 Opu

etc.. next Name in column 1


Thanks for your professional help!
Best Regards
Mark


Mark,

I would use a very different approach for that sort of solution. Although I
could modify my approach to work (and I would have to do some debugging on my
sort routine), it would take a very long time to go through that amount of
data.

What I would do, and in VBA, would be to copy the data table to a new sheet;
then sort it ascending by Name, and then by Data.

Then I would go through a rolling group of three names until I had the Minimum
Distance criterion satisfied; and delete the rest of the names.

It shouldn't be too tough to do. You can use the macro recorder to get some
code to do the copy and filtering routines. I can't work on it now, but may be
able to later on the day.


--ron

find result - only for expert
 

Dear expert!
I stoped on:
"Then I would go through a rolling group of three names
until I had the Minimum
Distance criterion satisfied; and delete the rest of the
names"

I need technical assistance again.

Best regards
Mark


-----Original Message-----
On Mon, 15 Nov 2004 23:00:42 -0800, "Mark"
wrote:

Hi Ron!

You code is very smart i've managed and appeared correct
result.
I've one more question:
My table has thousands rows and tens columns.
How to show in another sheet data perform neccesary
condition for all Name in column)? The form data could
be
e.g.:

Min_result for A = 4.8, Distance = 530
Name Data Distance Data_in_Column7 (additionally)
A 1.2 150 Xrt
A 2.2 280 Yur
A 1.4 100 Opu

'two rows below is next Name perform condition

Min_result for B = 6,2, Distance = 620
Name Data Distance Data_in_Column7 (additionally)
A 2.2 240 Pok
A 2.4 280 Utr
A 1.6 100 Opu

etc.. next Name in column 1


Thanks for your professional help!
Best Regards
Mark


Mark,

I would use a very different approach for that sort of
solution. Although I
could modify my approach to work (and I would have to do
some debugging on my
sort routine), it would take a very long time to go
through that amount of
data.

What I would do, and in VBA, would be to copy the data
table to a new sheet;
then sort it ascending by Name, and then by Data.

Then I would go through a rolling group of three names
until I had the Minimum
Distance criterion satisfied; and delete the rest of the
names.

It shouldn't be too tough to do. You can use the macro
recorder to get some
code to do the copy and filtering routines. I can't work
on it now, but may be
able to later on the day.


--ron
.

find result - only for expert
 

On Tue, 16 Nov 2004 23:16:54 -0800, "Mark" wrote:

Dear expert!
I stoped on:
"Then I would go through a rolling group of three names
until I had the Minimum
Distance criterion satisfied; and delete the rest of the
names"

I need technical assistance again.

Best regards
Mark

Mark,

I am going to be out of town for a few days and will be unable to work on this
any time real soon. But I'll get back to it when I'm back on line if no one
else has given you a solution.


--ron

find result - only for expert
 

On Tue, 16 Nov 2004 23:16:54 -0800, "Mark" wrote:

Dear expert!
I stoped on:
"Then I would go through a rolling group of three names
until I had the Minimum
Distance criterion satisfied; and delete the rest of the
names"

I need technical assistance again.

Best regards
Mark

Mark,

Try out the following SUB and see if it comes close to what you want.

The SUB assumes that your data is contiguous (no blank rows). It also assumes
that for every name, there is a series of three that will meet the Minimum
Distance Criteria. In other words, it does not handle the situation in which
the sum of the Distances for a Name is less than 500.

It also leaves intermediate worksheets in place, and does not give them any
particular name.

But it is a first stab.

=================================
Option Explicit

Sub Res()
Dim tbl As Range, c As Range
Dim Count As Integer
Const ResCount As Integer = 3
Const MinSumDistance As Integer = 500

Dim i As Long, j As Long
Dim SumDistance As Integer
Dim SumData As Double
Dim CurName As String

Dim Header() As String
Dim ColCt As Integer

Dim Grp(ResCount - 1, 2)


'copy data table to new sheet and sort

ActiveCell.CurrentRegion.Copy
Sheets.Add
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks
_
:=False, Transpose:=False
Application.CutCopyMode = False
ActiveCell.CurrentRegion.Sort Key1:=Range("A2"), Order1:=xlAscending,
Key2:= _
Range("B2"), Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom,
DataOption1:=xlSortNormal, _
DataOption2:=xlSortNormal



Set tbl = ActiveCell.CurrentRegion
ColCt = tbl.Columns.Count

i = 2

Application.ScreenUpdating = False

Do
CurName = tbl.Cells(i, 1)

Do
SumDistance = 0
For j = 0 To 2
Grp(j, 0) = tbl.Cells(i, 1) 'Name
Grp(j, 1) = tbl.Cells(i, 2) 'Data
Grp(j, 2) = tbl.Cells(i, 3) 'Distance
i = i + 1
Next j

For j = 0 To 2
SumDistance = SumDistance + Grp(j, 2)
Next j

If SumDistance < MinSumDistance Then
tbl.Cells(i - 3, 1).EntireRow.Hidden = True
i = i - 2
End If

Loop Until SumDistance = MinSumDistance

Do While tbl.Cells(i, 1) = CurName
tbl.Cells(i, 1).EntireRow.Hidden = True
i = i + 1
Loop

Loop Until tbl.Cells(i, 1) = ""



'Move processed cells to another worksheet
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy
Sheets.Add
ActiveSheet.Paste
Application.CutCopyMode = False

'Set up report
'Get header line

ReDim Header(1 To ColCt)
For j = 1 To ColCt
Header(j) = Cells(1, j)
Next j

i = 1

Range(Cells(i, 1), Cells(i, ColCt)).Delete (xlShiftUp)

Do
Range(Cells(i, 1), Cells(i + 2, ColCt)).Insert (xlShiftDown)
CurName = Cells(i + 4, 1)
SumData = 0
SumDistance = 0


'insert header row
For j = 1 To ColCt
Cells(i + 2, j) = Header(j)
Next j

For j = 3 To 5
SumData = SumData + Cells(i + j, 2)
SumDistance = SumDistance + Cells(i + j, 3)
Next j

Cells(i + 1, 1) = "Min_result for " _
& CurName & " = " & Format(SumData, "#.00") & _
", Distance = " & SumDistance

i = i + 6

Loop Until Cells(i, 1) = ""


Application.ScreenUpdating = True
[A1].Select
End Sub
===========================

--ron

find result - only for expert
 

Hi Ron!
I've wrote "find result - only for expert" as the most
difficult level in VBA whenewer i've wrote - you're master
of VBA.

Glad to read you last post!!
You invent quite nice script.
I add code when data is empty (delete row).
I struggling still with following problem:

If the same Name in table is <3 item (make impossible
min_result of three min) then omit or delate row with Name.
I wonder also, how find min_result in VBA (the smallest
result of data of the same Name and necessary distance
500) when data in my table will be:


Name Data Distance
A 1.1 11
A 2.3 20
A 3.5 12
A 5.9 470

Proper effect:
min_result = 1.1 + 2.3 + 5.9 = 9.3 (distance 501)
Script should be combination three of the smallest data of
the same name. Of course distanse 500 :)

Mr Expert, thank you for any help.
Sorry for my english..

Best Regards
Mark


-----Original Message-----
On Tue, 16 Nov 2004 23:16:54 -0800, "Mark"
wrote:

Dear expert!
I stoped on:
"Then I would go through a rolling group of three names
until I had the Minimum
Distance criterion satisfied; and delete the rest of the
names"

I need technical assistance again.

Best regards
Mark

Mark,

Try out the following SUB and see if it comes close to
what you want.

The SUB assumes that your data is contiguous (no blank
rows). It also assumes
that for every name, there is a series of three that will
meet the Minimum
Distance Criteria. In other words, it does not handle
the situation in which
the sum of the Distances for a Name is less than 500.

It also leaves intermediate worksheets in place, and does
not give them any
particular name.

But it is a first stab.

=================================
Option Explicit

Sub Res()
Dim tbl As Range, c As Range
Dim Count As Integer
Const ResCount As Integer = 3
Const MinSumDistance As Integer = 500

Dim i As Long, j As Long
Dim SumDistance As Integer
Dim SumData As Double
Dim CurName As String

Dim Header() As String
Dim ColCt As Integer

Dim Grp(ResCount - 1, 2)


'copy data table to new sheet and sort

ActiveCell.CurrentRegion.Copy
Sheets.Add
Selection.PasteSpecial Paste:=xlPasteValues,
Operation:=xlNone, SkipBlanks
_
:=False, Transpose:=False
Application.CutCopyMode = False
ActiveCell.CurrentRegion.Sort Key1:=Range("A2"),
Order1:=xlAscending,
Key2:= _
Range("B2"), Order2:=xlAscending,
Header:=xlGuess, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom,
DataOption1:=xlSortNormal, _
DataOption2:=xlSortNormal



Set tbl = ActiveCell.CurrentRegion
ColCt = tbl.Columns.Count

i = 2

Application.ScreenUpdating = False

Do
CurName = tbl.Cells(i, 1)

Do
SumDistance = 0
For j = 0 To 2
Grp(j, 0) = tbl.Cells(i, 1) 'Name
Grp(j, 1) = tbl.Cells(i, 2) 'Data
Grp(j, 2) = tbl.Cells(i, 3) 'Distance
i = i + 1
Next j

For j = 0 To 2
SumDistance = SumDistance + Grp(j, 2)
Next j

If SumDistance < MinSumDistance Then
tbl.Cells(i - 3, 1).EntireRow.Hidden = True
i = i - 2
End If

Loop Until SumDistance = MinSumDistance

Do While tbl.Cells(i, 1) = CurName
tbl.Cells(i, 1).EntireRow.Hidden = True
i = i + 1
Loop

Loop Until tbl.Cells(i, 1) = ""



'Move processed cells to another worksheet
Selection.SpecialCells(xlCellTypeVisible).Selec t
Selection.Copy
Sheets.Add
ActiveSheet.Paste
Application.CutCopyMode = False

'Set up report
'Get header line

ReDim Header(1 To ColCt)
For j = 1 To ColCt
Header(j) = Cells(1, j)
Next j

i = 1

Range(Cells(i, 1), Cells(i, ColCt)).Delete (xlShiftUp)

Do
Range(Cells(i, 1), Cells(i + 2, ColCt)).Insert
(xlShiftDown)
CurName = Cells(i + 4, 1)
SumData = 0
SumDistance = 0


'insert header row
For j = 1 To ColCt
Cells(i + 2, j) = Header(j)
Next j

For j = 3 To 5
SumData = SumData + Cells(i + j, 2)
SumDistance = SumDistance + Cells(i + j, 3)
Next j

Cells(i + 1, 1) = "Min_result for " _
& CurName & " = " & Format(SumData, "#.00") & _
", Distance = " & SumDistance

i = i + 6

Loop Until Cells(i, 1) = ""


Application.ScreenUpdating = True
[A1].Select
End Sub
===========================

--ron
.

find result - only for expert
 

On Mon, 22 Nov 2004 04:34:14 -0800, "Mark" wrote:

Hi Ron!
I've wrote "find result - only for expert" as the most
difficult level in VBA whenewer i've wrote - you're master
of VBA.

Glad to read you last post!!
You invent quite nice script.
I add code when data is empty (delete row).
I struggling still with following problem:

If the same Name in table is <3 item (make impossible
min_result of three min) then omit or delate row with Name.
I wonder also, how find min_result in VBA (the smallest
result of data of the same Name and necessary distance
500) when data in my table will be:


Name Data Distance
A 1.1 11
A 2.3 20
A 3.5 12
A 5.9 470

Proper effect:
min_result = 1.1 + 2.3 + 5.9 = 9.3 (distance 501)
Script should be combination three of the smallest data of
the same name. Of course distanse 500 :)

Mr Expert, thank you for any help.
Sorry for my english..

Best Regards
Mark


The problem of eliminating, from the report, names that do not meet the
criteria, either because there are less than three entries, or because the sum
of the entries does not add up to distance 500, is relatively trivial.

However, I've been considering the issue that the results may be
non-sequential, as in your example above. One solution would be to generate
all possible 3-row combinations; eliminate those where sum distance <=500, and
take the one with the minimum sum data.

Whether this is a reasonable approach depends on the size of your data set.
What is the maximum number of entries for a given name?

If it is 20, that results in 1,140 possible combinations.

If it is 100, then there would be 161,700 combinations.

If it is 1000, then there would be 166,167,000 combinations and computation by
this method would be lengthy.





-----Original Message-----
On Tue, 16 Nov 2004 23:16:54 -0800, "Mark"
wrote:

Dear expert!
I stoped on:
"Then I would go through a rolling group of three names
until I had the Minimum
Distance criterion satisfied; and delete the rest of the
names"

I need technical assistance again.

Best regards
Mark

Mark,

Try out the following SUB and see if it comes close to
what you want.

The SUB assumes that your data is contiguous (no blank
rows). It also assumes
that for every name, there is a series of three that will
meet the Minimum
Distance Criteria. In other words, it does not handle
the situation in which
the sum of the Distances for a Name is less than 500.

It also leaves intermediate worksheets in place, and does
not give them any
particular name.

But it is a first stab.

=================================
Option Explicit

Sub Res()
Dim tbl As Range, c As Range
Dim Count As Integer
Const ResCount As Integer = 3
Const MinSumDistance As Integer = 500

Dim i As Long, j As Long
Dim SumDistance As Integer
Dim SumData As Double
Dim CurName As String

Dim Header() As String
Dim ColCt As Integer

Dim Grp(ResCount - 1, 2)


'copy data table to new sheet and sort

ActiveCell.CurrentRegion.Copy
Sheets.Add
Selection.PasteSpecial Paste:=xlPasteValues,
Operation:=xlNone, SkipBlanks
_
:=False, Transpose:=False
Application.CutCopyMode = False
ActiveCell.CurrentRegion.Sort Key1:=Range("A2"),
Order1:=xlAscending,
Key2:= _
Range("B2"), Order2:=xlAscending,
Header:=xlGuess, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom,
DataOption1:=xlSortNormal, _
DataOption2:=xlSortNormal



Set tbl = ActiveCell.CurrentRegion
ColCt = tbl.Columns.Count

i = 2

Application.ScreenUpdating = False

Do
CurName = tbl.Cells(i, 1)

Do
SumDistance = 0
For j = 0 To 2
Grp(j, 0) = tbl.Cells(i, 1) 'Name
Grp(j, 1) = tbl.Cells(i, 2) 'Data
Grp(j, 2) = tbl.Cells(i, 3) 'Distance
i = i + 1
Next j

For j = 0 To 2
SumDistance = SumDistance + Grp(j, 2)
Next j

If SumDistance < MinSumDistance Then
tbl.Cells(i - 3, 1).EntireRow.Hidden = True
i = i - 2
End If

Loop Until SumDistance = MinSumDistance

Do While tbl.Cells(i, 1) = CurName
tbl.Cells(i, 1).EntireRow.Hidden = True
i = i + 1
Loop

Loop Until tbl.Cells(i, 1) = ""



'Move processed cells to another worksheet
Selection.SpecialCells(xlCellTypeVisible).Sele ct
Selection.Copy
Sheets.Add
ActiveSheet.Paste
Application.CutCopyMode = False

'Set up report
'Get header line

ReDim Header(1 To ColCt)
For j = 1 To ColCt
Header(j) = Cells(1, j)
Next j

i = 1

Range(Cells(i, 1), Cells(i, ColCt)).Delete (xlShiftUp)

Do
Range(Cells(i, 1), Cells(i + 2, ColCt)).Insert
(xlShiftDown)
CurName = Cells(i + 4, 1)
SumData = 0
SumDistance = 0


'insert header row
For j = 1 To ColCt
Cells(i + 2, j) = Header(j)
Next j

For j = 3 To 5
SumData = SumData + Cells(i + j, 2)
SumDistance = SumDistance + Cells(i + j, 3)
Next j

Cells(i + 1, 1) = "Min_result for " _
& CurName & " = " & Format(SumData, "#.00") & _
", Distance = " & SumDistance

i = i + 6

Loop Until Cells(i, 1) = ""


Application.ScreenUpdating = True
[A1].Select
End Sub
===========================

--ron
.


--ron

find result - only for expert
 

On Mon, 15 Nov 2004 07:12:46 -0500, "Tom Ogilvy" wrote:

Can you sort your data on the "Data" column ascending? Then you take the
first 3 sequential cells that sum to greater than 500.

--
Regards,
Tom Ogilvy

Tom,

Apparently the result may not be from sequential entries. The OP gives an
example:

======================
Name Data Distance
A 1.1 11
A 2.3 20
A 3.5 12
A 5.9 470

Proper effect:
min_result = 1.1 + 2.3 + 5.9 = 9.3 (distance 501)
======================

Any thoughts? (Other than generating all possible three row entries for each
name)






--ron