List of numbers

[verluc]

I want to create a macro that gives me tree
different numbers between 1 and 25
But the difference between this numbers is not greater then 15
This macro must give me all possibility combinations in the column A1 to A????
Thanks for help

[verluc]

On 2002-05-01 03:54, verluc wrote:
I want to create a macro that gives me tree
different numbers between 1 and 25
But the difference between this numbers is not greater then 15
This macro must give me all possibility combinations in the column A1 to A????
Thanks for help

An example :

1 2 3 CORRECT
1 2 18 INCORRECT

[kkknie]

I made the assumption in your problem statement that no two numbers could be more than 15 apart (and that 15 apart was OK). If the acutal problem is that no number can be more than 15 more than one other number, the code is different.

For example, I assumed 1,8,17 was not OK since 1 and 17 were too far apart. If this is the case, then the following code will generate the 9030 rows of numbers.

Sub Create_Numbers()

Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim iCount As Integer

iCount = 1

For i = 1 To 25
For j = 1 To 25
For k = 1 To 25
If i <> j And _
i <> k And _
j <> k And _
Abs(i - k) <= 15 And _
Abs(j - k) <= 15 And _
Abs(i - j) <= 15 Then
Cells(iCount, 1).Value = i
Cells(iCount, 2).Value = j
Cells(iCount, 3).Value = k
iCount = iCount + 1
End If

Next
Next
Next

End Sub

To use the other case (where every number must be at minimum 15 away from another number), the if statement would change to:

If i <> j And _
i <> k And _
j <> k And _
(Abs(i - k) <= 15 Or _
Abs(j - k) <= 15 Or _
Abs(i - j) <= 15) Then

and would return the same as if there were no <= 15 condtions at all.

Hope that makes sense...

K

[verluc]

On 2002-05-01 07:59, kkknie wrote:

I made the assumption in your problem statement that no two numbers could be more than 15 apart (and that 15 apart was OK). If the acutal problem is that no number can be more than 15 more than one other number, the code is different.

For example, I assumed 1,8,17 was not OK since 1 and 17 were too far apart. If this is the case, then the following code will generate the 9030 rows of numbers.

Sub Create_Numbers()

Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim iCount As Integer

iCount = 1

For i = 1 To 25
For j = 1 To 25
For k = 1 To 25
If i <> j And _
i <> k And _
j <> k And _
Abs(i - k) <= 15 And _
Abs(j - k) <= 15 And _
Abs(i - j) <= 15 Then
Cells(iCount, 1).Value = i
Cells(iCount, 2).Value = j
Cells(iCount, 3).Value = k
iCount = iCount + 1
End If

Next
Next
Next

End Sub

To use the other case (where every number must be at minimum 15 away from another number), the if statement would change to:

If i <> j And _
i <> k And _
j <> k And _
(Abs(i - k) <= 15 Or _
Abs(j - k) <= 15 Or _
Abs(i - j) <= 15) Then

and would return the same as if there were no <= 15 condtions at all.

Hope that makes sense...

K

Hi friend,

I thank you for your time.
When I run the second macro,then I get the
following numbers:

1 2 18

the difference between those numbers is more then 15 : see 2 and 18
Can you change your macro?
(the difference between all the 3 numbers may no be more then 15)
Thanks

[verluc]

On 2002-05-01 08:15, verluc wrote:

Hi friend,

I thank you for your time.
When I run the second macro,then I get the
following numbers:

1 2 18

the difference between those numbers is more then 15 : see 2 and 18
Can you change your macro?
(the difference between all the 3 numbers may no be more then 15)
Thanks

Any idea to change this macro?
Thanks

[Jay Petrulis]

Hi,

The next number in the sequence is bounded by +/- 15 from the prior number, correct?

Here are two routines to try. They are identical, except that the second one calls the RandBetween function in VBA. You must set a reference to the Analysis ToolPak to call it.

From the VBE
Tools>References>check atpvbaen.xls

Sub bounded_random()
Dim x As Integer
Randomize

Cells(1, 1) = Int(Rnd * 25) + 1
For x = 2 To 1000
    Cells(x, 1) = Int(Rnd * 25) + 1
    Do Until Abs(Cells(x, 1) - Cells(x - 1, 1)) <= 15
        Cells(x, 1) = Int(Rnd * 25) + 1
    Loop
Next x

End Sub

Sub bounded_random2()
Dim x As Integer
Randomize

Cells(1, 1) = randbetween(1, 25)
For x = 2 To 1000
    Cells(x, 1) = randbetween(1, 25)
    Do Until Abs(Cells(x, 1) - Cells(x - 1, 1)) <= 15
        Cells(x, 1) = randbetween(1, 25)
    Loop
Next x

End Sub

This places 1000 numbers in column A. Modify as needed.

Bye,
Jay

[Jay Petrulis]

Hi,

It would probably help if I read the question thoroughly.

You want an exhaustive list with the changes bounded? That means hypergeometric sampling (sampling without replacement).

The following routine might get closer to your goal.

Sub bounded_random()
Dim x As Long, samplesize As Long
Randomize

samplesize = 25
Cells(1, 1) = Int(Rnd * samplesize) + 1
If samplesize < 2 Then Exit Sub
For x = 2 To samplesize
    Cells(x, 1) = Int(Rnd * samplesize) + 1
    Do Until Abs(Cells(x, 1) - Cells(x - 1, 1)) <= 15 And _
    WorksheetFunction.CountIf(Range(Cells(1, 1), Cells(x, 1)), Cells(x, 1)) = 1
        Cells(x, 1) = Int(Rnd * samplesize) + 1
    Loop
Next x

End Sub

Note that this is *not* foolproof. Imagine your sample is of 100 numbers and the first element is 50 and then it works up to 75. There is a chance that the numbers will never come back down to 1-10 for instance.

It should work well for your sample size, but give it a try and report back.

Bye,
Jay

[ This Message was edited by: Jay Petrulis on 2002-05-04 09:31 ]

[verluc]

On 2002-05-04 09:26, Jay Petrulis wrote:
Hi,

It would probably help if I read the question thoroughly.

You want an exhaustive list with the changes bounded? That means hypergeometric sampling (sampling without replacement).

The following routine might get closer to your goal.

Sub bounded_random()
Dim x As Long, samplesize As Long
Randomize

samplesize = 25
Cells(1, 1) = Int(Rnd * samplesize) + 1
If samplesize < 2 Then Exit Sub
For x = 2 To samplesize
    Cells(x, 1) = Int(Rnd * samplesize) + 1
    Do Until Abs(Cells(x, 1) - Cells(x - 1, 1)) <= 15 And _
    WorksheetFunction.CountIf(Range(Cells(1, 1), Cells(x, 1)), Cells(x, 1)) = 1
        Cells(x, 1) = Int(Rnd * samplesize) + 1
    Loop
Next x

End Sub

Note that this is *not* foolproof. Imagine your sample is of 100 numbers and the first element is 50 and then it works up to 75. There is a chance that the numbers will never come back down to 1-10 for instance.

It should work well for your sample size, but give it a try and report back.

Bye,
Jay
Sorry,but that's not what I mean.
I need 3 different numbers on a row
They may not have a difference of more then 15 between each number.
Ex: 1 7 12
18 20 25
1 17 22 = not correct
Thanks for help.

[ This Message was edited by: Jay Petrulis on 2002-05-04 09:31 ]

[Jay Petrulis]

The nerve of some people. They post a question and expect *that specific question* to be answered! OK, so I forgot how to read twice.

This works for three columns, but I am trying to generalize this for more. That requires a recursive routine which I am unable to do as of yet.

Anyway, try the following. Warning: this is very slow, and it clears the active sheet, so please don't use it on a filled sheet without changing it.

Sub test()
Dim a As Integer, b As Integer, c As Integer
Dim lngCounter As Long, lastrow As Long
Dim population As Integer, sample As Integer, maxdiff As Integer
Dim CalcSetting, x As Long

population = 25
sample = 3
maxdiff = 15

If (population ^ sample) > 65536 Then
    MsgBox "Too many to handle"
    Exit Sub
End If

CalcSetting = Application.Calculation
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

With ActiveSheet
    .Cells.ClearContents
    For a = 1 To population
        For b = 1 To population
            For c = 1 To population
                .Cells(lngCounter + 1, 1) = a
                .Cells(lngCounter + 1, 2) = b
                .Cells(lngCounter + 1, 3) = c
                .Cells(lngCounter + 1, sample + 1).FormulaArray = _
                "=SUM(IF(ABS(RC[-" & sample - 1 & "]:RC[-1]-RC[-" _
                & sample & "]:RC[-2])<=" & maxdiff & ",1))"
                lngCounter = lngCounter + 1
            Next c
        Next b
    Next a
    If (population ^ sample) < 65536 Then
        .Rows(1).Insert
        .Cells(1, sample + 1) = "temp"
        .Cells(1, sample + 1).AutoFilter Field:=sample + 1, Criteria1:="<>" & sample - 1
        .Cells.SpecialCells(xlCellTypeVisible).Delete shift:=xlUp
        .Columns(sample + 1).ClearContents
    Else
        For x = 65536 To 1 Step -1
            If .Cells(x, sample + 1) <> sample - 1 Then Rows(x).Delete
        Next x
    End If
End With
Application.Calculation = CalcSetting
End Sub

Will try to get the recursive routine working.

Bye,
Jay

[verluc]

On 2002-05-04 22:47, Jay Petrulis wrote:
The nerve of some people. They post a question and expect *that specific question* to be answered! OK, so I forgot how to read twice.

This works for three columns, but I am trying to generalize this for more. That requires a recursive routine which I am unable to do as of yet.

Anyway, try the following. Warning: this is very slow, and it clears the active sheet, so please don't use it on a filled sheet without changing it.

Sub test()
Dim a As Integer, b As Integer, c As Integer
Dim lngCounter As Long, lastrow As Long
Dim population As Integer, sample As Integer, maxdiff As Integer
Dim CalcSetting, x As Long

population = 25
sample = 3
maxdiff = 15

If (population ^ sample) > 65536 Then
    MsgBox "Too many to handle"
    Exit Sub
End If

CalcSetting = Application.Calculation
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

With ActiveSheet
    .Cells.ClearContents
    For a = 1 To population
        For b = 1 To population
            For c = 1 To population
                .Cells(lngCounter + 1, 1) = a
                .Cells(lngCounter + 1, 2) = b
                .Cells(lngCounter + 1, 3) = c
                .Cells(lngCounter + 1, sample + 1).FormulaArray = _
                "=SUM(IF(ABS(RC[-" & sample - 1 & "]:RC[-1]-RC[-" _
                & sample & "]:RC[-2])<=" & maxdiff & ",1))"
                lngCounter = lngCounter + 1
            Next c
        Next b
    Next a
    If (population ^ sample) < 65536 Then
        .Rows(1).Insert
        .Cells(1, sample + 1) = "temp"
        .Cells(1, sample + 1).AutoFilter Field:=sample + 1, Criteria1:="<>" & sample - 1
        .Cells.SpecialCells(xlCellTypeVisible).Delete shift:=xlUp
        .Columns(sample + 1).ClearContents
    Else
        For x = 65536 To 1 Step -1
            If .Cells(x, sample + 1) <> sample - 1 Then Rows(x).Delete
        Next x
    End If
End With
Application.Calculation = CalcSetting
End Sub

Will try to get the recursive routine working.

Bye,
Jay