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
 
Sort by date Sort by votes
Yeah, yeah, I know. You didn't even have to say it. I missed the "different numbers" part.

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))+SUM(1/COUNTIF(RC[-" _
                & sample & "]:RC[-1],RC[-" & sample & "]:RC[-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:="<>" & (2 * sample) - 1
        .Cells.SpecialCells(xlCellTypeVisible).EntireRow.Delete
        .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

OK, I'm outta here on this one (until another flaw is noticed!!!).

More important is to get the recursive routine. Then, the next step would be to transform this all into VBA arrays, so that it can be scaled as kkknie's routine allows.
 
Upvote 0

Excel Facts

Save Often
If you start asking yourself if now is a good time to save your Excel workbook, the answer is Yes
On 2002-05-05 09:07, Jay Petrulis wrote:
Yeah, yeah, I know. You didn't even have to say it. I missed the "different numbers" part.

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))+SUM(1/COUNTIF(RC[-" _
                & sample & "]:RC[-1],RC[-" & sample & "]:RC[-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:="<>" & (2 * sample) - 1
        .Cells.SpecialCells(xlCellTypeVisible).EntireRow.Delete
        .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

OK, I'm outta here on this one (until another flaw is noticed!!!).

More important is to get the recursive routine. Then, the next step would be to transform this all into VBA arrays, so that it can be scaled as kkknie's routine allows.
Click to expand...
Sorry Jay,but I got 4 rows and not 3 rows.
Can you test it?
Thanks
 
Upvote 0
On 2002-05-05 11:53, verluc wrote:
On 2002-05-05 09:07, Jay Petrulis wrote:
Yeah, yeah, I know. You didn't even have to say it. I missed the "different numbers" part.

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))+SUM(1/COUNTIF(RC[-" _
                & sample & "]:RC[-1],RC[-" & sample & "]:RC[-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:="<>" & (2 * sample) - 1
        .Cells.SpecialCells(xlCellTypeVisible).EntireRow.Delete
        .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

OK, I'm outta here on this one (until another flaw is noticed!!!).

More important is to get the recursive routine. Then, the next step would be to transform this all into VBA arrays, so that it can be scaled as kkknie's routine allows.
Click to expand...
Sorry Jay,but I got 4 rows and not 3 rows.
Can you test it?
Thanks
Click to expand...
 
Upvote 0
On 2002-05-05 11:53, verluc wrote:
On 2002-05-05 09:07, Jay Petrulis wrote:
Yeah, yeah, I know. You didn't even have to say it. I missed the "different numbers" part.

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))+SUM(1/COUNTIF(RC[-" _
                & sample & "]:RC[-1],RC[-" & sample & "]:RC[-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:="<>" & (2 * sample) - 1
        .Cells.SpecialCells(xlCellTypeVisible).EntireRow.Delete
        .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

OK, I'm outta here on this one (until another flaw is noticed!!!).

More important is to get the recursive routine. Then, the next step would be to transform this all into VBA arrays, so that it can be scaled as kkknie's routine allows.
Click to expand...
Sorry Jay,but I got 4 rows and not 3 rows.
Can you test it?
Thanks
Sorry,I mean columns and not rows
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
174
Glenn Kennedy
G
S
  • Question
Multiple Conditions - Greater than less than
Replies
6
Views
330
Peter_SSs
Peter_SSs
R
  • Question
clink/link cell to send you to a different sheet
Replies
1
Views
203
Joe4
Joe4
dezibluenose
  • Solved
Trying to combine If statements
Replies
3
Views
141
etaf
etaf
J
  • Question
Formula won't repeat
Replies
2
Views
151
StephenCrump
S

Forum statistics

Threads
1,214,821
Messages
6,121,759
Members
449,048
Latest member
excelknuckles

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