Thanks Thanks:  0
Likes Likes:  0
Page 1 of 2 12 LastLast
Results 1 to 10 of 14

Thread: List of numbers

  1. #1
    Board Regular
    Join Date
    Mar 2002
    Posts
    1,451
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default

    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

  2. #2
    Board Regular
    Join Date
    Mar 2002
    Posts
    1,451
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default

    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

  3. #3
    Board Regular
    Join Date
    Apr 2002
    Location
    Greenwood, SC
    Posts
    677
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default


    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

  4. #4
    Board Regular
    Join Date
    Mar 2002
    Posts
    1,451
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default

    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

  5. #5
    Board Regular
    Join Date
    Mar 2002
    Posts
    1,451
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default

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

  6. #6
    MrExcel MVP Jay Petrulis's Avatar
    Join Date
    Mar 2002
    Location
    Chicago, IL USA
    Posts
    2,040
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default

    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

  7. #7
    MrExcel MVP Jay Petrulis's Avatar
    Join Date
    Mar 2002
    Location
    Chicago, IL USA
    Posts
    2,040
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default

    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 ]

  8. #8
    Board Regular
    Join Date
    Mar 2002
    Posts
    1,451
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default

    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 ]

  9. #9
    MrExcel MVP Jay Petrulis's Avatar
    Join Date
    Mar 2002
    Location
    Chicago, IL USA
    Posts
    2,040
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default

    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

  10. #10
    Board Regular
    Join Date
    Mar 2002
    Posts
    1,451
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default

    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

Some videos you may like

User Tag List

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •