find result - only for expert

M

Mark

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
 
T

Tom Ogilvy

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

ManualMan

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?
 
R

Ron Rosenfeld

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
Click to expand...

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
 
R

Ron Rosenfeld

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



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
Click to expand...

--ron
 
R

Ron Rosenfeld

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

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
Click to expand...

--ron
 
M

Mark

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

Click to expand...
 
R

Ron Rosenfeld

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
Click to expand...

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
 
M

Mark

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-----
Click to expand...
 
R

Ron Rosenfeld

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
Click to expand...

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
 
R

Ron Rosenfeld

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
Click to expand...

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
 
M

Mark

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-----
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,
Click to expand...
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
.
Click to expand...
Click to expand...
 
R

Ron Rosenfeld

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.
Click to expand...

Well you could cycle through the sorted results first, looking for either
series of Names less than three; and/or series of related distances less than
the MinDistance (500); and delete or hide those cells.
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 :)
Click to expand...

Since both the Data and the Distance can be non-sequential, I think you'll need
another loop or two. But I'll have to ponder this for a while; and we'll be
traveling over our Thanksgiving holiday, so I may not have much time over the
next week or so. If you don't have a solution when I get back, I'll work on it
some more.

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


Your english is clearly understandable, and that's what counts.
--ron
 
R

Ron Rosenfeld

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
Click to expand...

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-----
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,
Click to expand...
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
.
Click to expand...
Click to expand...

--ron
Click to expand...
 
R

Ron Rosenfeld

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

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
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

simplification problem (only for expert!) 9
Use only VBA - request for experts 2
find largest data (part2) hard work.. 1
use only VBA - help 5
VBA - Sum Quantity based on Unique IDs 3
Help in calculating tax % for Co2 emissions? 3
Dynamically creating formatted tables from raw data 1
a twist to relative ranges 5

Top