how to : possible combination with limited repititions rules

[MostafaShams]

Hello Everyone

i want to make all possible combination lets say of 5 digits for 5 numbers ( 1,2,3,4,5 )
11111,11112,11113

but i want to exclude certain outputs by limiting repetition of each char to 2 in a row
like 11234 is acceptable but 11123 is not , as ( 1 ) is repeated 3 times

can this be done ?
and is there a formula that calculate output numbers in this condition before execution ?

 

[maabadi]

Welcome to MrExcel Message Board.
1. I set range for you A1:A20 if you want change to what you want
2. I add Min, Max, Rept, Length to macro and set value based your request, if you want change it to others if you want.
Respectively they are Minimum, Maximum, Repetition(Max) , and Number of digit (length).
Try this:

Sub RandNumbers()
Dim A As Long, b As Long, C As Long, d As Long, e As Long, Rng As Range
Dim ws As Worksheet, Cell As Range, Min As Long, Max As Long, Rept As Long, length As Long

Min = 1
Max = 5
Rept = 2
length = 5
Set Rng = Range("A1:A20")
For Each Cell In Rng
For b = 1 To 2 * ((Max - Min + 1))
A = Int(((Max - Min + 1) * Rnd) + Min)
Range("FF" & b).Value = A
Next b
e = Range("FF1").Value
Debug.Print Len(CStr(e))
For b = 2 To 2 * ((Max - Min + 1))
d = Application.WorksheetFunction.CountIf(Range("FF1:FF" & b), Range("FF" & b))
If d < Rept + 1 And Len(CStr(e)) < length Then
e = e & Range("FF" & b).Value
Debug.Print e
End If
Next b
Range("FF1:FF" & b).ClearContents
Cell.Value = e
Next Cell
End Sub

 

[maabadi]

Also I added condition to remove duplicate number, Chang MaxNum to number of Values you want Create Macro.

Option Explicit

Sub RandNumbers()
Dim A As Long, b As Long, C As Long, d As Long, e As Long, Rng As Range
Dim ws As Worksheet, Cell As Range, Min As Long, Max As Long, Rept As Long, length As Long
Dim N As Long, MaxNum As Long, MinNum As Long, Rand As Long, i As Long
Min = 1
Max = 5
Rept = 2
length = 5
MinNum = 1        'Put the input of minimum number here
MaxNum = 100      'Put the input of maximum number here
N = MaxNum - MinNum + 1
Set Rng = Range("A1:A" & MaxNum - MinNum)
For Each Cell In Rng
For b = 1 To 2 * ((Max - Min + 1))
A = Int(((Max - Min + 1) * Rnd) + Min)
Range("FF" & b).Value = A
Next b
e = Range("FF1").Value
Debug.Print Len(CStr(e))
For b = 2 To 2 * ((Max - Min + 1))
d = Application.WorksheetFunction.CountIf(Range("FF1:FF" & b), Range("FF" & b))
If d < Rept + 1 And Len(CStr(e)) < length Then
e = e & Range("FF" & b).Value
Debug.Print e
End If
Next b
Range("FF1:FF" & b).ClearContents
Cell.Value = e
Next Cell


ReDim Unique(1 To N, 1 To 1)

For i = 1 To N
Randomize         'I put this inside the loop to make sure of generating "good" random numbers
    Do
        For b = 1 To 2 * ((Max - Min + 1))
        A = Int(((Max - Min + 1) * Rnd) + Min)
        Range("FF" & b).Value = A
        Next b
        e = Range("FF1").Value
        For b = 2 To 2 * ((Max - Min + 1))
        d = Application.WorksheetFunction.CountIf(Range("FF1:FF" & b), Range("FF" & b))
            If d < Rept + 1 And Len(CStr(e)) < length Then
                e = e & Range("FF" & b).Value

            End If
        Next b
        If IsUnique(e, Unique) Then Unique(i, 1) = e:  Exit Do
    Loop
Next
Sheet1.[A1].Resize(N) = Unique
End Sub

Function IsUnique(Num As Long, Data As Variant) As Boolean
Dim iFind As Long

On Error GoTo Unique
iFind = Application.WorksheetFunction.Match(Num, Data, 0)

If iFind > 0 Then IsUnique = False: Exit Function

Unique:
    IsUnique = True
End Function

 

[maabadi]

And this is 3rd version:

Sub RandNumbers()
Dim A As Long, b As Long, C As Long, d As Long, e As Long, Rng As Range, lr As Long
Dim ws As Worksheet, Cell As Range, Min As Long, Max As Long, Rept As Long, length As Long
Dim N As Long, MaxNum As Long, MinNum As Long, Rand As Long, i As Long
Min = 1
Max = 5
Rept = 2
length = 5
MinNum = 1        'Put the input of minimum number here
MaxNum = 500      'Put the input of maximum number here
N = MaxNum - MinNum + 1
Set Rng = Range("A1:A" & 2 * MaxNum - MinNum + 1)
For Each Cell In Rng
For b = 1 To 2 * ((Max - Min + 1))
A = Int(((Max - Min + 1) * Rnd) + Min)
Range("FF" & b).Value = A
Next b
e = Range("FF1").Value
Debug.Print Len(CStr(e))
For b = 2 To 2 * ((Max - Min + 1))
d = Application.WorksheetFunction.CountIf(Range("FF1:FF" & b), Range("FF" & b))
If d < Rept + 1 And Len(CStr(e)) < length Then
e = e & Range("FF" & b).Value
Debug.Print e
End If
Next b
Range("FF1:FF" & b).ClearContents
Cell.Value = e
Next Cell
Do Until Application.WorksheetFunction.Count(Range("A1:A" & 2 * MaxNum - MinNum + 1)) = lr

For i = 2 * MaxNum - MinNum + 1 To 1 Step -1
d = Application.WorksheetFunction.CountIf(Range("A1:A" & i), Range("A" & i))
If d > 1 Then
Range("A" & i).EntireRow.Delete
End If
Next i
lr = Cells(Rows.Count, 1).End(xlUp).Row
Loop
End Sub

 

[shg]

>> and is there a formula that calculate output numbers in this condition before execution ?

The problem you describe is equivalent to choosing 5 numbers from the set {1,1,2,2,3,3,4,4,5,5}, so

=combin(10, 5) = 252