List of numbers

V

verluc

Well-known Member
Joined
Mar 1, 2002
Messages
1,451
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
 

Excel Facts

Do you hate GETPIVOTDATA?
Prevent GETPIVOTDATA. Select inside a PivotTable. In the Analyze tab of the ribbon, open the dropown next to Options and turn it off
Sort by date Sort by votes
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
Click to expand...
An example :

1 2 3 CORRECT
1 2 18 INCORRECT
 
Upvote 0
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
 
Upvote 0
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
Click to expand...
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
 
Upvote 0
On 2002-05-01 08:15, verluc wrote:
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
Click to expand...
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
Click to expand...
Any idea to change this macro?
Thanks
 
Upvote 0
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

Code: 
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
 
Upvote 0
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.

Code: 
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
 
Upvote 0
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.

Code: 
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
Click to expand...
 
Upvote 0
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.

Code: 
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
 
Upvote 0
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.

Code: 
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
Click to expand...
 
Upvote 0
You must log in or register to reply here.

Similar threads

N
  • Question
Match and lookup combined
Replies
4
Views
164
Glenn Kennedy
G
S
  • Question
Multiple Conditions - Greater than less than
Replies
6
Views
289
Peter_SSs
Peter_SSs
R
  • Question
clink/link cell to send you to a different sheet
Replies
1
Views
200
Joe4
Joe4
dezibluenose
  • Solved
Trying to combine If statements
Replies
3
Views
117
etaf
etaf
J
  • Question
Formula won't repeat
Replies
2
Views
145
StephenCrump
S

Forum statistics

Threads
1,214,383
Messages
6,119,198
Members
448,874
Latest member
Lancelots

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top