Modifying Sub SortMatch

  • Thread starter Thread starter Max
  • Start date Start date
M

Max

Hi, seeking help with 2 follow-ons
to the Sub SortMatch() posted by JBeaucaire in .misc

1. > If [D4] = [D8] Then
How could the line above be amended to handle the scenario where the
condition is approximate, eg: stop the randomization if the absolute value
of
D4 is within 5% of D8's ?

2. How could the sub be modified to re-generate & "print" several sets of
possible result combinations (say 3 result sets) to the right of the source
data in A1:B8 (let's assume the source data is to be left intact)

Thanks for any insights
Max
 
I'm not sure I understand (especially how D4 or D8 changes), but maybe this
would get you closer:

Option Explicit
Sub SortMatch()

Dim wks As Worksheet
Dim TryCtr As Long
Dim MaxTries As Long
Dim SetCtr As Long
Dim MaxSets As Long

Set wks = ActiveSheet
MaxTries = 10
MaxSets = 3

Application.ScreenUpdating = False

With wks
.Columns(3).Insert
.Range("C1:C8").FormulaR1C1 = "=RAND()"

With .Range("A1:C8")
.Sort Key1:=.Columns(3), _
Order1:=xlAscending, _
Header:=xlGuess, _
OrderCustom:=1, _
MatchCase:=False, _
Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
End With

SetCtr = 0
TryCtr = 0
Do
'How could the line above be amended to
'handle the scenario where the
'condition is approximate, eg: stop the
'randomization if the absolute value
'of D4 is within 5% of D8's ?

'I think that this is the formula you're describing:
'=ABS((ABS(D4)/D8)-1)<=0.05

If IsNumeric(.Range("d8").Value) = False _
Or IsNumeric(.Range("d4").Value) = False Then
'what should happen
MsgBox "non-numerics in d4 and/or d8"
Exit Do
Else
If .Range("d8").Value = 0 Then
'what should happen?
MsgBox "D8 is 0"
Exit Do
Else
If Abs((Abs(.Range("D4").Value) / .Range("D8").Value) - 1) _
<= 0.05 Then
.Columns(3).Delete
MsgBox "Found one set"
SetCtr = SetCtr + 1
.Range("A1:C8").PrintOut preview:=True
If SetCtr >= MaxSets Then
Exit Do
End If
End If
End If
End If
TryCtr = TryCtr + 1
If TryCtr > MaxTries Then
MsgBox "Too many tries"
Exit Do
End If
Loop
End With

Application.ScreenUpdating = True
End Sub


Hi, seeking help with 2 follow-ons
to the Sub SortMatch() posted by JBeaucaire in .misc

1. > If [D4] = [D8] Then
How could the line above be amended to handle the scenario where the
condition is approximate, eg: stop the randomization if the absolute value
of
D4 is within 5% of D8's ?

2. How could the sub be modified to re-generate & "print" several sets of
possible result combinations (say 3 result sets) to the right of the source
data in A1:B8 (let's assume the source data is to be left intact)

Thanks for any insights
Max

JBeaucaire said:
Similar to above, but rather than manually having to press F9 over and
over,
here's a layout and a macro to do it in one click:

Text Values A1:A8
Numbers B1:B8
Formula in C4 =SUM(B1:B4)
Formula in C8 =SUM(B5:B8)

Now, here's the macro, run it and it shuffle the data until a matching set
is created and then stop.

Sub SortMatch()
Application.ScreenUpdating = False
Columns("C:C").Insert Shift:=xlToRight
Range("C1:C8").FormulaR1C1 = "=RAND()"

Start:
Range("A1:C8").Sort Key1:=Range("C1"), _
Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal

If [D4] = [D8] Then
Columns("C:C").Delete Shift:=xlToLeft
MsgBox "Found one set"
Else
GoTo Start
End If

Application.ScreenUpdating = True
End Sub
Click to expand...
Click to expand...
 
Dave, thanks for your sub

For the first part, this was what I meant
'=ABS(D4-D8)<=0.05

The orig sub by JBeaucaire random scrambled the source data within A1:B8
until C4=C8 where
Formula in C4 =SUM(B1:B4)
Formula in C8 =SUM(B5:B8)
Click to expand...
to achieve one solution of 2 "equal" groups of 4 items each (1st group in
A1:B4, 2nd group in A5:B8) where their col B sums are equal. The sub inserts
a new col C in the process, hence C4/C8 becomes D4/D8 with the objective
comparison being:
If [D4] = [D8] Then
Click to expand...

I had wanted to cater for the scenario where it may not be possible to make
it such that the 2 groups sums' are exactly equal, hence an approx solution
(eg a 5% difference or less in the sums) would be acceptable.

Additionally, for the 2nd part of my request, I wanted the sub to continue
to seek beyond just the 1st solution (there could be yet other combinations
which satisfy the criteria), hence the request to leave the source data
intact, and to seek and write the outputs (eg seek/write 3 results sets)
into adjacent areas to the right of the source data in A1:B8

Trust the above clarifies it better.
 
So you'll want to change this line:

If Abs((Abs(.Range("D4").Value) / .Range("D8").Value) - 1) <= 0.05 Then

to:

If Abs(.Range("D4").Value - .Range("D8").Value) <= 0.05 Then

I thought the rest of the code would do what you want.

I did add a couple more checks -- for numerics in those cells and a limit to the
number of attempts. You can change that maxtries to a very large number (still
has to fit into a long, though!).
Dave, thanks for your sub

For the first part, this was what I meant
'=ABS(D4-D8)<=0.05

The orig sub by JBeaucaire random scrambled the source data within A1:B8
until C4=C8 where
Formula in C4 =SUM(B1:B4)
Formula in C8 =SUM(B5:B8)
Click to expand...
to achieve one solution of 2 "equal" groups of 4 items each (1st group in
A1:B4, 2nd group in A5:B8) where their col B sums are equal. The sub inserts
a new col C in the process, hence C4/C8 becomes D4/D8 with the objective
comparison being:
If [D4] = [D8] Then
Click to expand...

I had wanted to cater for the scenario where it may not be possible to make
it such that the 2 groups sums' are exactly equal, hence an approx solution
(eg a 5% difference or less in the sums) would be acceptable.

Additionally, for the 2nd part of my request, I wanted the sub to continue
to seek beyond just the 1st solution (there could be yet other combinations
which satisfy the criteria), hence the request to leave the source data
intact, and to seek and write the outputs (eg seek/write 3 results sets)
into adjacent areas to the right of the source data in A1:B8

Trust the above clarifies it better.

Dave Peterson said:
I'm not sure I understand (especially how D4 or D8 changes), but maybe
this
would get you closer:

Option Explicit
Sub SortMatch()

Dim wks As Worksheet
Dim TryCtr As Long
Dim MaxTries As Long
Dim SetCtr As Long
Dim MaxSets As Long

Set wks = ActiveSheet
MaxTries = 10
MaxSets = 3

Application.ScreenUpdating = False

With wks
.Columns(3).Insert
.Range("C1:C8").FormulaR1C1 = "=RAND()"

With .Range("A1:C8")
.Sort Key1:=.Columns(3), _
Order1:=xlAscending, _
Header:=xlGuess, _
OrderCustom:=1, _
MatchCase:=False, _
Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
End With

SetCtr = 0
TryCtr = 0
Do
'How could the line above be amended to
'handle the scenario where the
'condition is approximate, eg: stop the
'randomization if the absolute value
'of D4 is within 5% of D8's ?

'I think that this is the formula you're describing:
'=ABS((ABS(D4)/D8)-1)<=0.05

If IsNumeric(.Range("d8").Value) = False _
Or IsNumeric(.Range("d4").Value) = False Then
'what should happen
MsgBox "non-numerics in d4 and/or d8"
Exit Do
Else
If .Range("d8").Value = 0 Then
'what should happen?
MsgBox "D8 is 0"
Exit Do
Else
If Abs((Abs(.Range("D4").Value) / .Range("D8").Value) -
1) _
<= 0.05 Then
.Columns(3).Delete
MsgBox "Found one set"
SetCtr = SetCtr + 1
.Range("A1:C8").PrintOut preview:=True
If SetCtr >= MaxSets Then
Exit Do
End If
End If
End If
End If
TryCtr = TryCtr + 1
If TryCtr > MaxTries Then
MsgBox "Too many tries"
Exit Do
End If
Loop
End With

Application.ScreenUpdating = True
End Sub
Click to expand...
Click to expand...
 
Thanks, I changed the line as advised, set MaxTries = 5000, and tried
running it, but I keep hitting the MsgBox "Too many tries" constantly? I did
reset the sheet by deleting the new col C inserted after each run.
 
Maybe the numbers aren't close?

I'd try changing MaxSets to 1 (just to see if it worked at all) and increase
that maxtries to something bigger (20000??).

If you wanted, you could add a line to help debug the problem:

debug.print Abs(.Range("D4").Value - .Range("D8").Value)

To see if those values are ever close enough.
 
ps. Maybe for testing purposes, you could plop some values in D4 and D8 that
meet the criteria--just to see if that works.
 
Thanks. Tried again. Stepped it through.

Relaxed the requirement by using this line:

If Abs(.Range("D4").Value - .Range("D8").Value) <= 30 Then

The LOOP seems to start it again at this line:

If IsNumeric(.Range("d8").Value) = False _
Or IsNumeric(.Range("d4").Value) = False Then

instead of (my guess):

With wks
.Columns(3).Insert
.Range("C1:C8").FormulaR1C1 = "=RAND()"

to re-generate it afresh for the 2nd possible solution

And it doesn't seem to write the results into the adjacent area? (I don't
want the printout preview)
 
I see...

Option Explicit
Sub SortMatch()

Dim wks As Worksheet
Dim TryCtr As Long
Dim MaxTries As Long
Dim SetCtr As Long
Dim MaxSets As Long

Set wks = ActiveSheet
MaxTries = 10
MaxSets = 3

Application.ScreenUpdating = False

With wks
'just insert column C once, but make it hidden
.Columns(3).Insert
.Columns(3).Hidden = True
.Range("C1:C8").FormulaR1C1 = "=RAND()"

SetCtr = 0
TryCtr = 0
Do
Application.Calculate '<--reevaluate =rand()

With .Range("A1:C8")
.Sort Key1:=.Columns(3), _
Order1:=xlAscending, _
Header:=xlGuess, _
OrderCustom:=1, _
MatchCase:=False, _
Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
End With

If IsNumeric(.Range("d8").Value) = False _
Or IsNumeric(.Range("d4").Value) = False Then
'what should happen
MsgBox "non-numerics in d4 and/or d8"
Exit Do
Else
If .Range("d8").Value = 0 Then
'what should happen?
MsgBox "D8 is 0"
Exit Do
Else
If Abs(.Range("D4").Value - .Range("D8").Value) <= 0.05 _
Then
SetCtr = SetCtr + 1
MsgBox "Found set #" & SetCtr
'remember column C is hidden
.Range("A1:d8").PrintOut preview:=True
If SetCtr >= MaxSets Then
Exit Do
End If
End If
End If
End If
TryCtr = TryCtr + 1
If TryCtr > MaxTries Then
MsgBox "Too many tries"
Exit Do
End If
Loop
.Columns(3).Delete
End With

Application.ScreenUpdating = True
End Sub
 
Dave, think the core's ok now, thanks. But instead of print preview(s) as the
outputs, I need the solution sets found to be written say, directly below the
source data in A1:B8, with each set spaced with an intervening blank row

What needs to be done to replace this line in your code to achieve this?
..Range("A1:d8").PrintOut preview:=True

Thanks
 
Option Explicit
Sub SortMatch()

Dim wks As Worksheet
Dim TryCtr As Long
Dim MaxTries As Long
Dim SetCtr As Long
Dim MaxSets As Long
Dim DestCell As Range

Set wks = ActiveSheet
MaxTries = 10
MaxSets = 3

Application.ScreenUpdating = False

With wks
'just insert column C once, but make it hidden
.Columns(3).Insert
.Columns(3).Hidden = True
.Range("C1:C8").FormulaR1C1 = "=RAND()"

Set DestCell = .Range("A10")

SetCtr = 0
TryCtr = 0
Do
Application.Calculate '<--reevaluate =rand()

With .Range("A1:C8")
.Sort Key1:=.Columns(3), _
Order1:=xlAscending, _
Header:=xlGuess, _
OrderCustom:=1, _
MatchCase:=False, _
Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
End With

If IsNumeric(.Range("d8").Value) = False _
Or IsNumeric(.Range("d4").Value) = False Then
'what should happen
MsgBox "non-numerics in d4 and/or d8"
Exit Do
Else
If .Range("d8").Value = 0 Then
'what should happen?
MsgBox "D8 is 0"
Exit Do
Else
If Abs(.Range("D4").Value - .Range("D8").Value) <= 0.05 _
Then
SetCtr = SetCtr + 1
MsgBox "Found set #" & SetCtr

.Range("a1:B8").Copy _
Destination:=DestCell

Set DestCell = DestCell.Offset(9, 0)

If SetCtr >= MaxSets Then
Exit Do
End If
End If
End If
End If
TryCtr = TryCtr + 1
If TryCtr > MaxTries Then
MsgBox "Too many tries"
Exit Do
End If
Loop
.Columns(3).Delete
End With

Application.ScreenUpdating = True
End Sub
 
Back
Top